diff options
author | Andy Wingo <wingo@pobox.com> | 2009-10-16 12:19:43 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-10-16 12:20:06 +0200 |
commit | 27c8177fe424fcf65a2c1cf3245b13382a2d22d9 (patch) | |
tree | 633f921c5ab499cdbb2b7965567d155a37f6bc53 /module/language/scheme/compile-ghil.scm | |
parent | b0fae4ecaa9f602f3183c35eb945c8050e1f3b68 (diff) | |
download | guile-27c8177fe424fcf65a2c1cf3245b13382a2d22d9.tar.gz |
remove GHIL, Elisp, and R5RS languages
GHIL is obsolete, and it's about time we got rid of it. Elisp and R5RS
were unmodified since their import from Guile-VM, so we ditch them too.
R5RS compilation is supported via compiling Scheme within an R5RS
environment.
Elisp will be supported when we merge in Daniel's work.
Diffstat (limited to 'module/language/scheme/compile-ghil.scm')
-rw-r--r-- | module/language/scheme/compile-ghil.scm | 494 |
1 files changed, 0 insertions, 494 deletions
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm deleted file mode 100644 index dc03af6cf..000000000 --- a/module/language/scheme/compile-ghil.scm +++ /dev/null @@ -1,494 +0,0 @@ -;;; Guile Scheme specification - -;; Copyright (C) 2001 Free Software Foundation, Inc. - -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Code: - -(define-module (language scheme compile-ghil) - #:use-module (system base pmatch) - #:use-module (system base language) - #:use-module (language ghil) - #:use-module (language scheme inline) - #:use-module (system vm objcode) - #:use-module (ice-9 receive) - #:use-module (ice-9 optargs) - #:use-module (language tree-il) - #:use-module ((system base compile) #:select (syntax-error)) - #:export (compile-ghil translate-1 - *translate-table* define-scheme-translator)) - -;;; environment := #f -;;; | MODULE -;;; | COMPILE-ENV -;;; compile-env := (MODULE LEXICALS|GHIL-ENV . EXTERNALS) -(define (cenv-module env) - (cond ((not env) #f) - ((module? env) env) - ((and (pair? env) (module? (car env))) (car env)) - (else (error "bad environment" env)))) - -(define (cenv-ghil-env env) - (cond ((not env) (make-ghil-toplevel-env)) - ((module? env) (make-ghil-toplevel-env)) - ((pair? env) - (if (struct? (cadr env)) - (cadr env) - (ghil-env-dereify (cadr env)))) - (else (error "bad environment" env)))) - -(define (cenv-externals env) - (cond ((not env) '()) - ((module? env) '()) - ((pair? env) (cddr env)) - (else (error "bad environment" env)))) - -(define (make-cenv module lexicals externals) - (cons module (cons lexicals externals))) - - - -(define (compile-ghil x e opts) - (save-module-excursion - (lambda () - (and=> (cenv-module e) set-current-module) - (call-with-ghil-environment (cenv-ghil-env e) '() - (lambda (env vars) - (let ((x (tree-il->scheme - (sc-expand x 'c '(compile load eval))))) - (let ((x (make-ghil-lambda env #f vars #f '() - (translate-1 env #f x))) - (cenv (make-cenv (current-module) - (ghil-env-parent env) - (if e (cenv-externals e) '())))) - (values x cenv cenv)))))))) - - -;;; -;;; Translator -;;; - -(define *forbidden-primitives* - ;; Guile's `procedure->macro' family is evil because it crosses the - ;; compilation boundary. One solution might be to evaluate calls to - ;; `procedure->memoizing-macro' at compilation time, but it may be more - ;; compicated than that. - '(procedure->syntax procedure->macro)) - -;; Looks up transformers relative to the current module at -;; compilation-time. See also the discussion of ghil-lookup in ghil.scm. -;; -;; FIXME shadowing lexicals? -(define (lookup-transformer head retrans) - (define (module-ref/safe mod sym) - (and mod - (and=> (module-variable mod sym) - (lambda (var) - ;; unbound vars can happen if the module - ;; definition forward-declared them - (and (variable-bound? var) (variable-ref var)))))) - (let* ((mod (current-module)) - (val (cond - ((symbol? head) (module-ref/safe mod head)) - ((pmatch head - ((@ ,modname ,sym) - (module-ref/safe (resolve-interface modname) sym)) - ((@@ ,modname ,sym) - (module-ref/safe (resolve-module modname) sym)) - (else #f))) - (else #f)))) - (cond - ((hashq-ref *translate-table* val)) - - ((macro? val) - (syntax-error #f "unknown kind of macro" head)) - - (else #f)))) - -(define (translate-1 e l x) - (let ((l (or l (location x)))) - (define (retrans x) (translate-1 e #f x)) - (define (retrans/loc x) (translate-1 e (or (location x) l) x)) - (cond ((pair? x) - (let ((head (car x)) (tail (cdr x))) - (cond - ((lookup-transformer head retrans/loc) - => (lambda (t) (t e l x))) - - ;; FIXME: lexical/module overrides of forbidden primitives - ((memq head *forbidden-primitives*) - (syntax-error l (format #f "`~a' is forbidden" head) - (cons head tail))) - - (else - (let ((tail (map retrans tail))) - (or (and (symbol? head) - (try-inline-with-env e l (cons head tail))) - (make-ghil-call e l (retrans head) tail))))))) - - ((symbol? x) - (make-ghil-ref e l (ghil-var-for-ref! e x))) - - ;; fixme: non-self-quoting objects like #<foo> - (else - (make-ghil-quote e l x))))) - -(define (valid-bindings? bindings . it-is-for-do) - (define (valid-binding? b) - (pmatch b - ((,sym ,var) (guard (symbol? sym)) #t) - ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t) - (else #f))) - (and (list? bindings) (and-map valid-binding? bindings))) - -(define *translate-table* (make-hash-table)) - -(define-macro (-> form) - `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form))) - -(define-macro (define-scheme-translator sym . clauses) - `(hashq-set! (@ (language scheme compile-ghil) *translate-table*) - (module-ref (current-module) ',sym) - (lambda (e l exp) - (define (retrans x) - ((@ (language scheme compile-ghil) translate-1) - e - (or ((@@ (language scheme compile-ghil) location) x) l) - x)) - (define syntax-error (@ (system base compile) syntax-error)) - (pmatch (cdr exp) - ,@clauses - ,@(if (assq 'else clauses) '() - `((else - (syntax-error l (format #f "bad ~A" ',sym) exp)))))))) - -(define-scheme-translator quote - ;; (quote OBJ) - ((,obj) - (-> (quote obj)))) - -(define-scheme-translator quasiquote - ;; (quasiquote OBJ) - ((,obj) - (-> (quasiquote (trans-quasiquote e l obj 0))))) - -(define-scheme-translator define - ;; (define NAME VAL) - ((,name ,val) (guard (symbol? name) - (ghil-toplevel-env? (ghil-env-parent e))) - (-> (define (ghil-var-define! (ghil-env-parent e) name) - (maybe-name-value! (retrans val) name)))) - ;; (define (NAME FORMALS...) BODY...) - (((,name . ,formals) . ,body) (guard (symbol? name)) - ;; -> (define NAME (lambda FORMALS BODY...)) - (retrans `(define ,name (lambda ,formals ,@body))))) - -(define-scheme-translator set! - ;; (set! NAME VAL) - ((,name ,val) (guard (symbol? name)) - (-> (set (ghil-var-for-set! e name) (retrans val)))) - - ;; FIXME: Would be nice to verify the values of @ and @@ relative - ;; to imported modules... - (((@ ,modname ,name) ,val) (guard (symbol? name) - (list? modname) - (and-map symbol? modname) - (not (ghil-var-is-bound? e '@))) - (-> (set (ghil-var-at-module! e modname name #t) (retrans val)))) - - (((@@ ,modname ,name) ,val) (guard (symbol? name) - (list? modname) - (and-map symbol? modname) - (not (ghil-var-is-bound? e '@@))) - (-> (set (ghil-var-at-module! e modname name #f) (retrans val)))) - - ;; (set! (NAME ARGS...) VAL) - (((,name . ,args) ,val) (guard (symbol? name)) - ;; -> ((setter NAME) ARGS... VAL) - (retrans `((setter ,name) . (,@args ,val))))) - -(define-scheme-translator if - ;; (if TEST THEN [ELSE]) - ((,test ,then) - (-> (if (retrans test) (retrans then) (retrans '(begin))))) - ((,test ,then ,else) - (-> (if (retrans test) (retrans then) (retrans else))))) - -(define-scheme-translator and - ;; (and EXPS...) - (,tail - (-> (and (map retrans tail))))) - -(define-scheme-translator or - ;; (or EXPS...) - (,tail - (-> (or (map retrans tail))))) - -(define-scheme-translator begin - ;; (begin EXPS...) - (,tail - (-> (begin (map retrans tail))))) - -(define-scheme-translator let - ;; (let NAME ((SYM VAL) ...) BODY...) - ((,name ,bindings . ,body) (guard (symbol? name) - (valid-bindings? bindings)) - ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...)) - (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body))) - (,name ,@(map cadr bindings))))) - - ;; (let () BODY...) - ((() . ,body) - ;; Note: this differs from `begin' - (-> (begin (list (trans-body e l body))))) - - ;; (let ((SYM VAL) ...) BODY...) - ((,bindings . ,body) (guard (valid-bindings? bindings)) - (let ((vals (map (lambda (b) - (maybe-name-value! (retrans (cadr b)) (car b))) - bindings))) - (call-with-ghil-bindings e (map car bindings) - (lambda (vars) - (-> (bind vars vals (trans-body e l body)))))))) - -(define-scheme-translator let* - ;; (let* ((SYM VAL) ...) BODY...) - ((() . ,body) - (retrans `(let () ,@body))) - ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym)) - (retrans `(let ((,sym ,val)) (let* ,rest ,@body))))) - -(define-scheme-translator letrec - ;; (letrec ((SYM VAL) ...) BODY...) - ((,bindings . ,body) (guard (valid-bindings? bindings)) - (call-with-ghil-bindings e (map car bindings) - (lambda (vars) - (let ((vals (map (lambda (b) - (maybe-name-value! - (retrans (cadr b)) (car b))) - bindings))) - (-> (bind vars vals (trans-body e l body)))))))) - -(define-scheme-translator cond - ;; (cond (CLAUSE BODY...) ...) - (() (retrans '(begin))) - (((else . ,body)) (retrans `(begin ,@body))) - (((,test) . ,rest) (retrans `(or ,test (cond ,@rest)))) - (((,test => ,proc) . ,rest) - ;; FIXME hygiene! - (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest))))) - (((,test . ,body) . ,rest) - (retrans `(if ,test (begin ,@body) (cond ,@rest))))) - -(define-scheme-translator case - ;; (case EXP ((KEY...) BODY...) ...) - ((,exp . ,clauses) - (retrans - ;; FIXME hygiene! - `(let ((_t ,exp)) - ,(let loop ((ls clauses)) - (cond ((null? ls) '(begin)) - ((eq? (caar ls) 'else) `(begin ,@(cdar ls))) - (else `(if (memv _t ',(caar ls)) - (begin ,@(cdar ls)) - ,(loop (cdr ls)))))))))) - -(define-scheme-translator do - ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...) - ((,bindings (,test . ,result) . ,body) - (let ((sym (map car bindings)) - (val (map cadr bindings)) - (update (map cddr bindings))) - (define (next s x) (if (pair? x) (car x) s)) - (retrans - ;; FIXME hygiene! - `(letrec ((_l (lambda ,sym - (if ,test - (begin ,@result) - (begin ,@body - (_l ,@(map next sym update))))))) - (_l ,@val)))))) - -(define-scheme-translator lambda - ;; (lambda FORMALS BODY...) - ((,formals . ,body) - (receive (syms rest) (parse-formals formals) - (call-with-ghil-environment e syms - (lambda (e vars) - (receive (meta body) (parse-lambda-meta body) - (-> (lambda vars rest meta (trans-body e l body))))))))) - -(define-scheme-translator delay - ;; FIXME not hygienic - ((,expr) - (retrans `(make-promise (lambda () ,expr))))) - -(define-scheme-translator @ - ((,modname ,sym) - (-> (ref (ghil-var-at-module! e modname sym #t))))) - -(define-scheme-translator @@ - ((,modname ,sym) - (-> (ref (ghil-var-at-module! e modname sym #f))))) - -(define *the-compile-toplevel-symbol* 'compile-toplevel) -(define-scheme-translator eval-when - ((,when . ,body) (guard (list? when) (and-map symbol? when)) - (if (memq 'compile when) - (primitive-eval `(begin . ,body))) - (if (memq 'load when) - (retrans `(begin . ,body)) - (retrans `(begin))))) - -(define-scheme-translator apply - ;; FIXME: not hygienic, relies on @apply not being shadowed - (,args (retrans `(@apply ,@args)))) - -;; FIXME: we could add inliners for `list' and `vector' - -(define-scheme-translator @apply - ((,proc ,arg1 . ,args) - (let ((args (cons (retrans arg1) (map retrans args)))) - (cond ((and (symbol? proc) - (not (ghil-var-is-bound? e proc)) - (and=> (module-variable (current-module) proc) - (lambda (var) - (and (variable-bound? var) - (lookup-apply-transformer (variable-ref var)))))) - ;; that is, a variable, not part of this compilation - ;; unit, but defined in the toplevel environment, and has - ;; an apply transformer registered - => (lambda (t) (t e l args))) - (else - (-> (inline 'apply (cons (retrans proc) args)))))))) - -(define-scheme-translator call-with-values - ;; FIXME: not hygienic, relies on @call-with-values not being shadowed - ((,producer ,consumer) - (retrans `(@call-with-values ,producer ,consumer))) - (else #f)) - -(define-scheme-translator @call-with-values - ((,producer ,consumer) - (-> (mv-call (retrans producer) (retrans consumer))))) - -(define-scheme-translator call-with-current-continuation - ;; FIXME: not hygienic, relies on @call-with-current-continuation - ;; not being shadowed - ((,proc) - (retrans `(@call-with-current-continuation ,proc))) - (else #f)) - -(define-scheme-translator @call-with-current-continuation - ((,proc) - (-> (inline 'call/cc (list (retrans proc)))))) - -(define-scheme-translator receive - ((,formals ,producer-exp . ,body) - ;; Lovely, self-referential usage. Not strictly necessary, the - ;; macro would do the trick; but it's good to test the mv-bind - ;; code. - (receive (syms rest) (parse-formals formals) - (let ((producer (retrans `(lambda () ,producer-exp)))) - (call-with-ghil-bindings e syms - (lambda (vars) - (-> (mv-bind producer vars rest - (trans-body e l body))))))))) - -(define-scheme-translator values - ((,x) (retrans x)) - (,args - (-> (values (map retrans args))))) - -(define (lookup-apply-transformer proc) - (cond ((eq? proc values) - (lambda (e l args) - (-> (values* args)))) - (else #f))) - -(define (trans-quasiquote e l x level) - (cond ((not (pair? x)) x) - ((memq (car x) '(unquote unquote-splicing)) - (let ((l (location x))) - (pmatch (cdr x) - ((,obj) - (cond - ((zero? level) - (if (eq? (car x) 'unquote) - (-> (unquote (translate-1 e l obj))) - (-> (unquote-splicing (translate-1 e l obj))))) - (else - (list (car x) (trans-quasiquote e l obj (1- level)))))) - (else (syntax-error l (format #f "bad ~A" (car x)) x))))) - ((eq? (car x) 'quasiquote) - (let ((l (location x))) - (pmatch (cdr x) - ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level)))) - (else (syntax-error l (format #f "bad ~A" (car x)) x))))) - (else (cons (trans-quasiquote e l (car x) level) - (trans-quasiquote e l (cdr x) level))))) - -(define (trans-body e l body) - (define (define->binding df) - (pmatch (cdr df) - ((,name ,val) (guard (symbol? name)) (list name val)) - (((,name . ,formals) . ,body) (guard (symbol? name)) - (list name `(lambda ,formals ,@body))) - (else (syntax-error (location df) "bad define" df)))) - ;; main - (let loop ((ls body) (ds '())) - (pmatch ls - (() (syntax-error l "bad body" body)) - (((define . _) . _) - (loop (cdr ls) (cons (car ls) ds))) - (else - (if (null? ds) - (translate-1 e l `(begin ,@ls)) - (translate-1 e l `(letrec ,(map define->binding ds) ,@ls))))))) - -(define (parse-formals formals) - (cond - ;; (lambda x ...) - ((symbol? formals) (values (list formals) #t)) - ;; (lambda (x y z) ...) - ((list? formals) (values formals #f)) - ;; (lambda (x y . z) ...) - ((pair? formals) - (let loop ((l formals) (v '())) - (if (pair? l) - (loop (cdr l) (cons (car l) v)) - (values (reverse! (cons l v)) #t)))) - (else (syntax-error (location formals) "bad formals" formals)))) - -(define (parse-lambda-meta body) - (cond ((or (null? body) (null? (cdr body))) (values '() body)) - ((string? (car body)) - (values `((documentation . ,(car body))) (cdr body))) - (else (values '() body)))) - -(define (maybe-name-value! val name) - (cond - ((ghil-lambda? val) - (if (not (assq-ref (ghil-lambda-meta val) 'name)) - (set! (ghil-lambda-meta val) - (acons 'name name (ghil-lambda-meta val)))))) - val) - -(define (location x) - (and (pair? x) - (let ((props (source-properties x))) - (and (not (null? props)) - props)))) |