diff options
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/ice-9/Makefile.am | 2 | ||||
-rw-r--r-- | module/ice-9/annotate.scm | 24 | ||||
-rw-r--r-- | module/language/scheme/amatch.scm | 37 | ||||
-rw-r--r-- | module/language/scheme/expand.scm | 300 | ||||
-rw-r--r-- | module/system/base/compile.scm | 9 |
6 files changed, 361 insertions, 12 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index bf137ba48..171f9f1d2 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -45,6 +45,7 @@ SOURCES = \ $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) SCHEME_LANG_SOURCES = \ + language/scheme/amatch.scm language/scheme/expand.scm \ language/scheme/compile-ghil.scm language/scheme/spec.scm \ language/scheme/inline.scm diff --git a/module/ice-9/Makefile.am b/module/ice-9/Makefile.am index a9ff09c7c..8c94d8320 100644 --- a/module/ice-9/Makefile.am +++ b/module/ice-9/Makefile.am @@ -30,7 +30,7 @@ modpath = ice-9 # and forth between interpreted and compiled code, we end up using more # of the C stack than the interpreter would have; so avoid that by # putting these core modules first. -SOURCES = psyntax-pp.scm boot-9.scm \ +SOURCES = psyntax-pp.scm annotate.scm boot-9.scm \ and-let-star.scm calling.scm common-list.scm \ debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ format.scm getopt-long.scm hcons.scm i18n.scm \ diff --git a/module/ice-9/annotate.scm b/module/ice-9/annotate.scm index f09eb1fa9..faa5f859a 100644 --- a/module/ice-9/annotate.scm +++ b/module/ice-9/annotate.scm @@ -17,22 +17,24 @@ (define-module (ice-9 annotate) - :export (<annotation> annotation? annotate make-annotation + :export (<annotation> annotation? annotate deannotate make-annotation annotation-expression annotation-source annotation-stripped set-annotation-stripped!)) (define <annotation> (make-vtable "prprpw" (lambda (struct port) - (display "#<annotation of ") - (display (struct-ref 0)) - (display ">")))) + (display "#<annotation of " port) + (display (struct-ref struct 0) port) + (display ">" port)))) (define (annotation? x) (and (struct? x) (eq? (struct-vtable x) <annotation>))) -(define (make-annotation e s stripped?) - (make-struct <annotation> 0 e s stripped?)) +(define (make-annotation e s . stripped?) + (if (null? stripped?) + (make-struct <annotation> 0 e s #f) + (apply make-struct <annotation> 0 e s stripped?))) (define (annotation-expression a) (struct-ref a 0)) @@ -44,11 +46,17 @@ (struct-set! a 2 #t)) (define (annotate e) - (cond ((list? e) + (cond ((and (list? e) (not (null? e))) (make-annotation (map annotate e) (source-properties e) #f)) ((pair? e) (make-annotation (cons (annotate (car e)) (annotate (cdr e))) (source-properties e) #f)) (else e))) - +(define (deannotate e) + (cond ((list? e) + (map deannotate e)) + ((pair? e) + (cons (deannotate (car e)) (deannotate (cdr e)))) + ((annotation? e) (deannotate (annotation-expression e))) + (else e))) diff --git a/module/language/scheme/amatch.scm b/module/language/scheme/amatch.scm new file mode 100644 index 000000000..4ac973620 --- /dev/null +++ b/module/language/scheme/amatch.scm @@ -0,0 +1,37 @@ +(define-module (language scheme amatch) + #:use-module (ice-9 syncase) + #:export (amatch apat)) +;; FIXME: shouldn't have to export apat... + +;; This is exactly the same as pmatch except that it unpacks annotations +;; as needed. + +(define-syntax amatch + (syntax-rules (else guard) + ((_ (op arg ...) cs ...) + (let ((v (op arg ...))) + (amatch v cs ...))) + ((_ v) (if #f #f)) + ((_ v (else e0 e ...)) (begin e0 e ...)) + ((_ v (pat (guard g ...) e0 e ...) cs ...) + (let ((fk (lambda () (amatch v cs ...)))) + (apat v pat + (if (and g ...) (begin e0 e ...) (fk)) + (fk)))) + ((_ v (pat e0 e ...) cs ...) + (let ((fk (lambda () (amatch v cs ...)))) + (apat v pat (begin e0 e ...) (fk)))))) + +(define-syntax apat + (syntax-rules (_ quote unquote) + ((_ v _ kt kf) kt) + ((_ v () kt kf) (if (null? v) kt kf)) + ((_ v (quote lit) kt kf) + (if (equal? v (quote lit)) kt kf)) + ((_ v (unquote var) kt kf) (let ((var v)) kt)) + ((_ v (x . y) kt kf) + (if (apair? v) + (let ((vx (acar v)) (vy (acdr v))) + (apat vx x (apat vy y kt kf) kf)) + kf)) + ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf)))) diff --git a/module/language/scheme/expand.scm b/module/language/scheme/expand.scm new file mode 100644 index 000000000..b8dc85f3e --- /dev/null +++ b/module/language/scheme/expand.scm @@ -0,0 +1,300 @@ +;;; 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 expand) + #:use-module (language scheme amatch) + #:use-module (ice-9 annotate) + #:use-module (ice-9 optargs) + #:use-module ((ice-9 syncase) #:select (sc-macro)) + #:use-module ((system base compile) #:select (syntax-error)) + #:export (expand *expand-table* define-scheme-expander)) + +(define (aref x) (if (annotation? x) (annotation-expression x) x)) +(define (apair? x) (pair? (aref x))) +(define (acar x) (car (aref x))) +(define (acdr x) (cdr (aref x))) +(define (acaar x) (acar (acar x))) +(define (acdar x) (acdr (acar x))) +(define (acadr x) (acar (acdr x))) +(define (acddr x) (acdr (acdr x))) +(define (aloc x) (and (annotation? x) (annotation-source x))) +(define (re-annotate x y) + (if (annotation? x) + (make-annotation y (annotation-source x)) + y)) +(define-macro (-> exp) `(re-annotate x ,exp)) + +(define* (expand x #:optional (mod (current-module)) (once? #f)) + (define re-expand + (if once? + (lambda (x) x) + (lambda (x) (expand x mod once?)))) + (let ((exp (if (annotation? x) (annotation-expression x) x))) + (cond + ((pair? exp) + (let ((head (car exp)) (tail (cdr exp))) + (cond + ;; allow macros to be unquoted into the output of a macro + ;; expansion + ((or (symbol? head) (macro? head)) + (let ((val (cond + ((macro? head) head) + ((module-variable mod head) + => (lambda (var) + ;; unbound vars can happen if the module + ;; definition forward-declared them + (and (variable-bound? var) (variable-ref var)))) + (else #f)))) + (cond + ((hashq-ref *expand-table* val) + => (lambda (expand1) (expand1 x re-expand))) + + ((defmacro? val) + (re-expand (-> (apply (defmacro-transformer val) + (deannotate tail))))) + + ((eq? val sc-macro) + ;; syncase! + (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure)) + (sc-expand3 (@@ (ice-9 syncase) sc-expand3))) + (re-expand + (with-fluids ((eec (module-eval-closure mod))) + ;; fixme + (sc-expand3 (deannotate exp) 'c '(compile load eval)))))) + + ((primitive-macro? val) + (syntax-error (aloc x) "unhandled primitive macro" head)) + + ((macro? val) + (syntax-error (aloc x) "unknown kind of macro" head)) + + (else + (-> (cons head (map re-expand tail))))))) + + (else + (-> (map re-expand exp)))))) + + (else x)))) + + +(define *expand-table* (make-hash-table)) + +(define-macro (define-scheme-expander sym . clauses) + `(hashq-set! (@ (language scheme expand) *expand-table*) + ,sym + (lambda (x re-expand) + (define syntax-error (@ (system base compile) syntax-error)) + (amatch (acdr x) + ,@clauses + ,@(if (assq 'else clauses) '() + `((else + (syntax-error (aloc x) (format #f "bad ~A" ',sym) x)))))))) + +(define-scheme-expander quote + ;; (quote OBJ) + ((,obj) x)) + +(define-scheme-expander quasiquote + ;; (quasiquote OBJ) + ((,obj) + (-> `(,'quasiquote + ,(let lp ((x obj) (level 0)) + (cond ((not (apair? x)) x) + ((memq (acar x) '(,'unquote ,'unquote-splicing)) + (amatch (acdr x) + ((,obj) + (cond + ((zero? level) + (-> `(,(acar x) ,(re-expand obj)))) + (else + (-> `(,(acar x) ,(lp obj (1- level))))))) + (else (syntax-error (aloc x) (format #f "bad ~A" (acar x)) x)))) + ((eq? (acar x) 'quasiquote) + (amatch (acdr x) + ((,obj) (-> `(,'quasiquote ,(lp obj (1+ level))))) + (else (syntax-error (aloc x) "bad quasiquote" x)))) + (else (-> (cons (lp (acar x) level) (lp (acdr x) level)))))))))) + +(define-scheme-expander define + ;; (define NAME VAL) + ((,name ,val) (guard (symbol? name)) + (-> `(define ,name ,(re-expand val)))) + ;; (define (NAME FORMALS...) BODY...) + (((,name . ,formals) . ,body) (guard (symbol? name)) + ;; -> (define NAME (lambda FORMALS BODY...)) + (re-expand (-> `(define ,name (lambda ,formals . ,body)))))) + +(define-scheme-expander set! + ;; (set! (NAME ARGS...) VAL) + (((,name . ,args) ,val) (guard (symbol? name) + (not (eq? name '@)) (not (eq? name '@@))) + ;; -> ((setter NAME) ARGS... VAL) + (re-expand (-> `((setter ,name) ,@args ,val)))) + + ;; (set! NAME VAL) + ((,name ,val) (guard (symbol? name)) + (-> `(set! ,name ,(re-expand val))))) + +(define-scheme-expander if + ;; (if TEST THEN [ELSE]) + ((,test ,then) + (-> `(if ,(re-expand test) ,(re-expand then)))) + ((,test ,then ,else) + (-> `(if ,(re-expand test) ,(re-expand then) ,(re-expand else))))) + +(define-scheme-expander and + ;; (and EXPS...) + (,tail + (-> `(and . ,(map re-expand tail))))) + +(define-scheme-expander or + ;; (or EXPS...) + (,tail + (-> `(or . ,(map re-expand tail))))) + +(define-scheme-expander begin + ;; (begin EXPS...) + (,tail + (-> `(begin . ,(map re-expand tail))))) + +(define (valid-bindings? bindings . it-is-for-do) + (define (valid-binding? b) + (amatch b + ((,sym ,var) (guard (symbol? sym)) #t) + ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t) + (else #f))) + (and (list? (aref bindings)) + (and-map valid-binding? (aref bindings)))) + +(define-scheme-expander let + ;; (let NAME ((SYM VAL) ...) BODY...) + ((,name ,bindings . ,body) (guard (symbol? name) + (valid-bindings? bindings)) + ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...)) + (re-expand (-> `(letrec ((,name (lambda ,(map acar (aref bindings)) + . ,body))) + (,name . ,(map acadr (aref bindings))))))) + + ;; (let ((SYM VAL) ...) BODY...) + ((,bindings . ,body) (guard (valid-bindings? bindings)) + (-> `(let ,(map (lambda (x) + ;; nb, relies on -> non-hygiene + (-> `(,(acar x) ,(re-expand (acadr x))))) + (aref bindings)) + . ,(map re-expand body))))) + +(define-scheme-expander let* + ;; (let* ((SYM VAL) ...) BODY...) + ((() . ,body) + (re-expand (-> `(let () . ,body)))) + ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym)) + (re-expand (-> `(let ((,sym ,val)) (let* ,rest . ,body)))))) + +(define-scheme-expander letrec + ;; (letrec ((SYM VAL) ...) BODY...) + ((,bindings . ,body) (guard (valid-bindings? bindings)) + (-> `(letrec ,(map (lambda (x) + ;; nb, relies on -> non-hygiene + (-> `(,(acar x) ,(re-expand (acadr x))))) + (aref bindings)) + . ,(map re-expand body))))) + +(define-scheme-expander cond + ;; (cond (CLAUSE BODY...) ...) + (() (-> '(begin))) + (((else . ,body)) (re-expand (-> `(begin ,@body)))) + (((,test) . ,rest) (re-expand (-> `(or ,test (cond ,@rest))))) + (((,test => ,proc) . ,rest) + ;; FIXME hygiene! + (re-expand (-> `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))) + (((,test . ,body) . ,rest) + (re-expand (-> `(if ,test (begin ,@body) (cond ,@rest)))))) + +(define-scheme-expander case + ;; (case EXP ((KEY...) BODY...) ...) + ((,exp . ,clauses) + ;; FIXME hygiene! + (re-expand + (->`(let ((_t ,exp)) + ,(let loop ((ls clauses)) + (cond ((null? ls) '(begin)) + ((eq? (acaar ls) 'else) `(begin ,@(acdar ls))) + (else `(if (memv _t ',(acaar ls)) + (begin ,@(acdar ls)) + ,(loop (acdr ls))))))))))) + +(define-scheme-expander do + ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...) + ((,bindings (,test . ,result) . ,body) (guard (valid-bindings? bindings #t)) + (let ((sym (map acar (aref bindings))) + (val (map acadr (aref bindings))) + (update (map acddr (aref bindings)))) + (define (next s x) (if (pair? x) (car x) s)) + (re-expand + ;; FIXME hygiene! + (-> `(letrec ((_l (lambda ,sym + (if ,test + (begin ,@result) + (begin ,@body + (_l ,@(map next sym update))))))) + (_l ,@val))))))) + +(define-scheme-expander lambda + ;; (lambda FORMALS BODY...) + ((,formals . ,body) + (-> `(lambda ,formals . ,(map re-expand body))))) + +(define-scheme-expander delay + ;; FIXME not hygienic + ((,expr) + (re-expand `(make-promise (lambda () ,expr))))) + +(define-scheme-expander @ + ((,modname ,sym) + x)) + +(define-scheme-expander @@ + ((,modname ,sym) + x)) + +(define-scheme-expander eval-case + (,clauses + (-> `(eval-case . ,(map (lambda (x) + (-> `(,(acar x) . ,(map re-expand (acdr x))))) + clauses))))) + +(define (trans-body e l body) + (define (define->binding df) + (amatch (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 '())) + (amatch 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))))))) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index e54b4ac05..891902367 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -45,9 +45,12 @@ ,thunk (lambda (key loc msg exp) (if (pair? loc) - (format (current-error-port) - "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp) - (format (current-error-port) + (let ((file (or (assq-ref loc 'filename) "unknown file")) + (line (assq-ref loc 'line)) + (col (assq-ref loc 'column))) + (format (current-error-port) + "~A:~A:~A: ~A: ~A~%" file line col msg exp)) + (format (current-error-port) "unknown location: ~A: ~S~%" msg exp))))) |