merge guile-vm to guile

An attempt to pull in the original history from guile-vm into guile itself.

1 files changed, 341 insertions, 0 deletions

diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
new file mode 100644
index 000000000..40ce46675
--- /dev/null
+++ b/module/language/scheme/translate.scm
@@ -0,0 +1,341 @@
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language scheme translate)
+  :use-module (system base pmatch)
+  :use-module (system base language)
+  :use-module (system il ghil)
+  :use-module (system il inline)
+  :use-module (ice-9 receive)
+  :use-module (srfi srfi-39)
+  :use-module ((system base compile) :select (syntax-error))
+  :export (translate))
+
+
+(define (translate x e)
+  (call-with-ghil-environment (make-ghil-mod e) '()
+    (lambda (env vars)
+      (make-ghil-lambda env #f vars #f (trans env #f x)))))
+
+
+;;;
+;;; 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 procedure->memoizing-macro))
+
+(define (lookup-transformer e head retrans)
+  (let* ((mod (ghil-mod-module (ghil-env-mod e)))
+         (val (and=> (module-variable mod head) 
+                     (lambda (var)
+                       ;; unbound vars can happen if the module
+                       ;; definition forward-declared them
+                       (and (variable-bound? var) (variable-ref var))))))
+    (cond
+     ((or (primitive-macro? val) (eq? val eval-case))
+      (or (assq-ref primitive-syntax-table head)
+          (syntax-error #f "unhandled primitive macro" head)))
+
+     ((defmacro? val)
+      (lambda (env loc exp)
+        (retrans (apply (defmacro-transformer val) (cdr exp)))))
+
+     ((and (macro? val) (eq? (macro-name val) 'sc-macro))
+      ;; syncase!
+      (let* ((the-syncase-module (resolve-module '(ice-9 syncase)))
+             (eec (module-ref the-syncase-module 'expansion-eval-closure))
+             (sc-expand3 (module-ref the-syncase-module 'sc-expand3)))
+        (lambda (env loc exp)
+          (retrans
+           (with-fluids ((eec (module-eval-closure mod)))
+             (sc-expand3 exp 'c '(compile load eval)))))))
+
+     ((macro? val)
+      (syntax-error #f "unknown kind of macro" head))
+
+     (else #f))))
+
+(define (trans e l x)
+  (define (retrans x) (trans e l x))
+  (cond ((pair? x)
+         (let ((head (car x)) (tail (cdr x)))
+           (cond
+            ((lookup-transformer e head retrans)
+             => (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 (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-lookup e x)))
+
+        ;; fixme: non-self-quoting objects like #<foo>
+	(else
+         (make-ghil-quote e l #:obj 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-macro (make-pmatch-transformers env loc retranslate . body)
+  (define exp (gensym))
+  (define (make1 clause)
+    (let ((sym (car clause))
+          (clauses (cdr clause)))
+      `(cons ',sym
+             (lambda (,env ,loc ,exp)
+               (define (,retranslate x) (trans ,env ,loc x))
+               (pmatch (cdr ,exp)
+                ,@clauses
+                (else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp)))))))
+  `(list ,@(map make1 body)))
+
+(define *the-compile-toplevel-symbol* 'compile-toplevel)
+
+(define primitive-syntax-table
+  (make-pmatch-transformers
+   e l retrans
+   (quote
+    ;; (quote OBJ)
+    ((,obj) (make-ghil-quote e l obj)))
+    
+   (quasiquote
+    ;; (quasiquote OBJ)
+    ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj))))
+
+   (define
+    ;; (define NAME VAL)
+    ((,name ,val) (guard (symbol? name) (ghil-env-toplevel? e))
+     (make-ghil-define e l (ghil-define (ghil-env-parent e) name)
+                       (retrans val)))
+    ;; (define (NAME FORMALS...) BODY...)
+    (((,name . ,formals) . ,body) (guard (symbol? name))
+     ;; -> (define NAME (lambda FORMALS BODY...))
+     (retrans `(define ,name (lambda ,formals ,@body)))))
+
+   (set!
+    ;; (set! NAME VAL)
+    ((,name ,val) (guard (symbol? name))
+     (make-ghil-set e l (ghil-lookup e name) (retrans val)))
+
+    ;; (set! (NAME ARGS...) VAL)
+    (((,name . ,args) ,val) (guard (symbol? name))
+     ;; -> ((setter NAME) ARGS... VAL)
+     (retrans `((setter ,name) . (,@args ,val)))))
+
+   (if
+    ;; (if TEST THEN [ELSE])
+    ((,test ,then)
+     (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin))))
+    ((,test ,then ,else)
+     (make-ghil-if e l (retrans test) (retrans then) (retrans else))))
+
+   (and
+    ;; (and EXPS...)
+    (,tail (make-ghil-and e l (map retrans tail))))
+
+   (or
+    ;; (or EXPS...)
+    (,tail (make-ghil-or e l (map retrans tail))))
+
+   (begin
+     ;; (begin EXPS...)
+     (,tail (make-ghil-begin e l (map retrans tail))))
+
+   (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'
+     (make-ghil-begin e l (list (trans-body e l body))))
+    
+    ;; (let ((SYM VAL) ...) BODY...)
+    ((,bindings . ,body) (guard (valid-bindings? bindings))
+     (let ((vals (map retrans (map cadr bindings))))
+       (call-with-ghil-bindings e (map car bindings)
+         (lambda (vars)
+           (make-ghil-bind e l vars vals (trans-body e l body)))))))
+
+   (let*
+    ;; (let* ((SYM VAL) ...) BODY...)
+    ((() . ,body)
+     (retrans `(let () ,@body)))
+    ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
+     (retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
+
+   (letrec
+    ;; (letrec ((SYM VAL) ...) BODY...)
+    ((,bindings . ,body) (guard (valid-bindings? bindings))
+     (call-with-ghil-bindings e (map car bindings)
+        (lambda (vars)
+          (let ((vals (map retrans (map cadr bindings))))
+            (make-ghil-bind e l vars vals (trans-body e l body)))))))
+
+   (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)))))
+
+   (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))))))))))
+
+    (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))))))
+
+    (lambda
+     ;; (lambda FORMALS BODY...)
+     ((,formals . ,body)
+      (receive (syms rest) (parse-formals formals)
+        (call-with-ghil-environment e syms
+       (lambda (env vars)
+            (make-ghil-lambda env l vars rest (trans-body env l body)))))))
+
+    (eval-case
+     (,clauses
+      (retrans
+       `(begin
+          ,@(let ((toplevel? (ghil-env-toplevel? e)))
+              (let loop ((seen '()) (in clauses) (runtime '()))
+                (cond
+                 ((null? in) runtime)
+                 (else
+                  (pmatch (car in)
+                   ((else . ,body)
+                    (if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen)))
+                        (primitive-eval `(begin ,@body)))
+                    (if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen)
+                        runtime
+                        body))
+                   ((,keys . ,body) (guard (list? keys) (and-map symbol? keys))
+                    (for-each (lambda (k)
+                                (if (memq k seen)
+                                    (syntax-error l "eval-case condition seen twice" k)))
+                              keys)
+                    (if (and toplevel? (memq *the-compile-toplevel-symbol* keys))
+                        (primitive-eval `(begin ,@body)))
+                    (loop (append keys seen)
+                          (cdr in)
+                          (if (memq (if toplevel? 'load-toplevel 'evaluate) keys)
+                              (append runtime body)
+                              runtime)))
+                   (else (syntax-error l "bad eval-case clause" (car in))))))))))))))
+
+(define (trans-quasiquote e l x)
+  (cond ((not (pair? x)) x)
+	((memq (car x) '(unquote unquote-splicing))
+	 (let ((l (location x)))
+	   (pmatch (cdr x)
+	     ((,obj)
+	      (if (eq? (car x) 'unquote)
+		  (make-ghil-unquote e l (trans e l obj))
+		  (make-ghil-unquote-splicing e l (trans e l obj))))
+	     (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
+	(else (cons (trans-quasiquote e l (car x))
+		    (trans-quasiquote e l (cdr x))))))
+
+(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)
+           (trans e l `(begin ,@ls))
+           (trans 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 (location x)
+  (and (pair? x)
+       (let ((props (source-properties x)))
+	 (and (not (null? props))
+	      (cons (assq-ref props 'line) (assq-ref props 'column))))))