diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 1997-09-10 20:07:04 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 1997-09-10 20:07:04 +0000 |
commit | 7a0ff2f80714f8c8ece3d8aa53a561dc209f696e (patch) | |
tree | 8152d5b235f44d5f2285e65bb0aeeaff4abfed37 | |
parent | 7332df664494f9a206b2460524f95e8dffe240a4 (diff) | |
download | guile-7a0ff2f80714f8c8ece3d8aa53a561dc209f696e.tar.gz |
* * boot-9.scm (primitive-macro?): New procedure.
* slib.scm: Added hack which transfers syntactic information from
the builtin variable `define' to the slib version if module (ice-9
syncase) has been loaded. This is necessary to get correct
expansion inside the slib module.
* psyntax.ss (build-let, build-named-let): New output
constructors.
(build-lexical-var): Seed gensym with symbolic name.
(self-evaluating?): Add keywords among self-evaluating types.
(let): New core form.
(if): Removed from core language.
(or, and, let, cond): Removed syntactic definitions.
(sc-expand3): New procedure: Expander which takes optional mode
and eval-syntactic-expanders-when arguments.
* syncase.scm (psyncomp): New procedure: Recompiles psyntax.pp.
Should be used inside the (ice-9 syncase) module with (use-syntax
syncase) and with the current directory containing the psyntax.ss
source.
Added hack to transfer syntactic information from the builtin
variable `define' to the slib version if module (ice-9 slib) has
been loaded.
-rw-r--r-- | ice-9/ChangeLog | 45 | ||||
-rw-r--r-- | ice-9/boot-9.scm | 44 | ||||
-rw-r--r-- | ice-9/psyntax.ss | 128 | ||||
-rw-r--r-- | ice-9/slib.scm | 6 | ||||
-rw-r--r-- | ice-9/syncase.scm | 82 |
5 files changed, 204 insertions, 101 deletions
diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index b89b95233..b48228dbe 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,48 @@ +Wed Sep 10 20:12:45 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se> + +* * boot-9.scm (primitive-macro?): New procedure. + + * slib.scm: Added hack which transfers syntactic information from + the builtin variable `define' to the slib version if module (ice-9 + syncase) has been loaded. This is necessary to get correct + expansion inside the slib module. + + * psyntax.ss (build-let, build-named-let): New output + constructors. + (build-lexical-var): Seed gensym with symbolic name. + (self-evaluating?): Add keywords among self-evaluating types. + (let): New core form. + (if): Removed from core language. + (or, and, let, cond): Removed syntactic definitions. + (sc-expand3): New procedure: Expander which takes optional mode + and eval-syntactic-expanders-when arguments. + + * syncase.scm (psyncomp): New procedure: Recompiles psyntax.pp. + Should be used inside the (ice-9 syncase) module with (use-syntax + syncase) and with the current directory containing the psyntax.ss + source. + Added hack to transfer syntactic information from the builtin + variable `define' to the slib version if module (ice-9 slib) has + been loaded. + +Fri Sep 5 05:47:36 1997 Mikael Djurfeldt <mdj@faun.nada.kth.se> + + * syncase.scm (sc-interface, sc-expand): Removed hook setup. + (syncase): Publish syntax transformer to be used with + `use-syntax'. + (sc-macro): Use this as the value when publishing macros. + + * boot-9.scm (module-type): Added `transformer'. + (make-module): Modified initialization. + (module-transformer, set-module-transformer!): Selector and + mutator for module-associated transformer. + (set-current-module): Use module-transformer to set + `scm:eval-transformer'. + (module-use!): Previous change reverted. +* (use-syntax): New function: Install a transformer in current + module. + (sc-interface, sc-expand): Removed! :) + Fri Sep 5 03:09:09 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se> * emacs.scm (emacs-load): Added new parameter `module'. diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 4ab5c429f..d635c2b16 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1258,7 +1258,8 @@ ;; bindings that would otherwise not be found locally in the module. ;; (define module-type - (make-record-type 'module '(obarray uses binder eval-closure name kind) + (make-record-type 'module + '(obarray uses binder eval-closure transformer name kind) %print-module)) ;; make-module &opt size uses binder @@ -1291,7 +1292,7 @@ "Lazy-binder expected to be a procedure or #f." binder)) (let ((module (module-constructor (make-vector size '()) - uses binder #f #f #f))) + uses binder #f #f #f #f))) ;; We can't pass this as an argument to module-constructor, ;; because we need it to close over a pointer to the module @@ -1313,6 +1314,8 @@ (define set-module-binder! (record-modifier module-type 'binder)) (define module-eval-closure (record-accessor module-type 'eval-closure)) (define set-module-eval-closure! (record-modifier module-type 'eval-closure)) +(define module-transformer (record-accessor module-type 'transformer)) +(define set-module-transformer! (record-modifier module-type 'transformer)) (define module-name (record-accessor module-type 'name)) (define set-module-name! (record-modifier module-type 'name)) (define module-kind (record-accessor module-type 'kind)) @@ -1622,27 +1625,21 @@ ;; (define the-module #f) -;; Syntax case macro support +;; scm:eval-transformer ;; -(define sc-interface #f) -(define sc-expand #f) +(define scm:eval-transformer #f) ;; set-current-module module ;; ;; set the current module as viewed by the normalizer. ;; (define (set-current-module m) - (let ((from-sc-module? (and the-module - (memq sc-interface (module-uses the-module)))) - (to-sc-module? (and m - (memq sc-interface (module-uses m))))) - (set! the-module m) - (if from-sc-module? (set! scm:eval-transformer #f)) - (if m - (begin - (set! *top-level-lookup-closure* (module-eval-closure the-module)) - (if to-sc-module? (set! scm:eval-transformer sc-expand))) - (set! *top-level-lookup-closure* #f)))) + (set! the-module m) + (if m + (begin + (set! *top-level-lookup-closure* (module-eval-closure the-module)) + (set! scm:eval-transformer (module-transformer the-module))) + (set! *top-level-lookup-closure* #f))) ;; current-module @@ -1726,10 +1723,7 @@ ;; (define (module-use! module interface) (set-module-uses! module - (cons interface (delq! interface (module-uses module)))) - (if (and (eq? interface sc-interface) - (eq? module (current-module))) - (set! scm:eval-transformer sc-expand))) + (cons interface (delq! interface (module-uses module))))) ;;; {Recursive Namespaces} @@ -2128,6 +2122,12 @@ ;;; {Macros} ;;; +(define (primitive-macro? m) + (and (macro? m) + (not (macro-transformer m)))) + +;;; {Defmacros} +;;; (define macro-table (make-weak-key-hash-table 523)) (define xformer-table (make-weak-key-hash-table 523)) @@ -2565,6 +2565,10 @@ (defmacro use-modules modules `(process-use-modules ',modules)) +(define (use-syntax transformer) + (set-module-transformer! (current-module) transformer) + (set! scm:eval-transformer transformer)) + (define define-private define) (defmacro define-public args diff --git a/ice-9/psyntax.ss b/ice-9/psyntax.ss index 18bfc877a..f45ac9191 100644 --- a/ice-9/psyntax.ss +++ b/ice-9/psyntax.ss @@ -379,6 +379,18 @@ (car exps) `(begin ,@exps)))) +(define build-let + (lambda (src vars val-exps body-exp) + (if (null? vars) + body-exp + `(let ,(map list vars val-exps) ,body-exp)))) + +(define build-named-let + (lambda (src vars val-exps body-exp) + (if (null? vars) + body-exp + `(let ,(car vars) ,(map list (cdr vars) val-exps) ,body-exp)))) + (define build-letrec (lambda (src vars val-exps body-exp) (if (null? vars) @@ -387,13 +399,13 @@ (define-syntax build-lexical-var (syntax-rules () - ((_ src id) (gensym)))) + ((_ src id) (gensym id generated-symbols)))) (define-syntax self-evaluating? (syntax-rules () ((_ e) (let ((x e)) - (or (boolean? x) (number? x) (string? x) (char? x) (null? x)))))) + (or (boolean? x) (number? x) (string? x) (char? x) (null? x) (keyword? x)))))) ) (define-structure (syntax-object expression wrap)) @@ -1593,6 +1605,37 @@ (lambda (vars body) (build-lambda s vars body))))))) +(global-extend 'core 'let + (let () + (define (chi-let e r w s constructor ids vals exps) + (if (not (valid-bound-ids? ids)) + (syntax-error e "duplicate bound variable in") + (let ((labels (gen-labels ids)) + (new-vars (map gen-var ids))) + (let ((nw (make-binding-wrap ids labels w)) + (nr (extend-var-env labels new-vars r))) + (constructor s + new-vars + (map (lambda (x) (chi x r w)) vals) + (chi-body exps (source-wrap e nw s) nr nw)))))) + (lambda (e r w s) + (syntax-case e () + ((_ ((id val) ...) e1 e2 ...) + (chi-let e r w s + build-let + (syntax (id ...)) + (syntax (val ...)) + (syntax (e1 e2 ...)))) + ((_ f ((id val) ...) e1 e2 ...) + (id? (syntax f)) + (chi-let e r w s + build-named-let + (syntax (f id ...)) + (syntax (val ...)) + (syntax (e1 e2 ...)))) + (_ (syntax-error (source-wrap e w s))))))) + + (global-extend 'core 'letrec (lambda (e r w s) (syntax-case e () @@ -1610,21 +1653,6 @@ (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w))))))) (_ (syntax-error (source-wrap e w s)))))) -(global-extend 'core 'if - (lambda (e r w s) - (syntax-case e () - ((_ test then) - (build-conditional s - (chi (syntax test) r w) - (chi (syntax then) r w) - (chi-void))) - ((_ test then else) - (build-conditional s - (chi (syntax test) r w) - (chi (syntax then) r w) - (chi (syntax else) r w))) - (_ (syntax-error (source-wrap e w s)))))) - (global-extend 'core 'set! (lambda (e r w s) @@ -1800,6 +1828,19 @@ (cadr x) (chi-top x null-env top-wrap m esew))))) +(set! sc-expand3 + (let ((m 'e) (esew '(eval))) + (lambda (x . rest) + (if (and (pair? x) (equal? (car x) noexpand)) + (cadr x) + (chi-top x + null-env + top-wrap + (if (null? rest) m (car rest)) + (if (or (null? rest) (null? (cdr rest))) + esew + (cadr rest))))))) + (set! identifier? (lambda (x) (nonsymbol-id? x))) @@ -1984,32 +2025,6 @@ ((dummy . pattern) (syntax template)) ...))))))) -(define-syntax or - (lambda (x) - (syntax-case x () - ((_) (syntax #f)) - ((_ e) (syntax e)) - ((_ e1 e2 e3 ...) - (syntax (let ((t e1)) (if t t (or e2 e3 ...)))))))) - -(define-syntax and - (lambda (x) - (syntax-case x () - ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f))) - ((_ e) (syntax e)) - ((_) (syntax #t))))) - -(define-syntax let - (lambda (x) - (syntax-case x () - ((_ ((x v) ...) e1 e2 ...) - (andmap identifier? (syntax (x ...))) - (syntax ((lambda (x ...) e1 e2 ...) v ...))) - ((_ f ((x v) ...) e1 e2 ...) - (andmap identifier? (syntax (f x ...))) - (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f) - v ...)))))) - (define-syntax let* (lambda (x) (syntax-case x () @@ -2022,25 +2037,6 @@ (binding (car bindings))) (syntax (let (binding) body))))))))) -(define-syntax cond - (lambda (x) - (syntax-case x () - ((_ m1 m2 ...) - (let f ((clause (syntax m1)) (clauses (syntax (m2 ...)))) - (if (null? clauses) - (syntax-case clause (else =>) - ((else e1 e2 ...) (syntax (begin e1 e2 ...))) - ((e0) (syntax (let ((t e0)) (if t t)))) - ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t))))) - ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...)))) - (_ (syntax-error x))) - (with-syntax ((rest (f (car clauses) (cdr clauses)))) - (syntax-case clause (else =>) - ((e0) (syntax (let ((t e0)) (if t t rest)))) - ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest)))) - ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest))) - (_ (syntax-error x)))))))))) - (define-syntax do (lambda (orig-x) (syntax-case orig-x () @@ -2136,16 +2132,16 @@ (syntax-case x () ((_ e) (error 'unquote - "expression ,~s not valid outside of quasiquote" - (syntax-object->datum (syntax e))))))) + "expression ,~s not valid outside of quasiquote" + (syntax-object->datum (syntax e))))))) (define-syntax unquote-splicing (lambda (x) (syntax-case x () ((_ e) (error 'unquote-splicing - "expression ,@~s not valid outside of quasiquote" - (syntax-object->datum (syntax e))))))) + "expression ,@~s not valid outside of quasiquote" + (syntax-object->datum (syntax e))))))) (define-syntax case (lambda (x) diff --git a/ice-9/slib.scm b/ice-9/slib.scm index 43eaa1db6..30ca098a4 100644 --- a/ice-9/slib.scm +++ b/ice-9/slib.scm @@ -173,6 +173,12 @@ `(define-public ,@(cdr exp)) `(%system-define ,@(cdr exp)))))) +;;; Hack to make syncase macros work in the slib module +(if (nested-ref the-root-module '(app modules ice-9 syncase)) + (set-object-property! (module-local-variable (current-module) 'define) + '*sc-expander* + '(define))) + (define (software-type) 'UNIX) (slib:load (in-vicinity (library-vicinity) "require.scm")) diff --git a/ice-9/syncase.scm b/ice-9/syncase.scm index a02487585..427f722f2 100644 --- a/ice-9/syncase.scm +++ b/ice-9/syncase.scm @@ -21,28 +21,44 @@ +(define-public sc-macro + (procedure->memoizing-macro + (lambda (exp env) + (sc-expand exp)))) + ;;; Exported variables +(define-public sc-expand #f) +(define-public sc-expand3 #f) (define-public install-global-transformer #f) (define-public syntax-dispatch #f) (define-public syntax-error #f) (define-public bound-identifier=? #f) (define-public datum->syntax-object #f) -(define-public define-syntax #f) -(define-public fluid-let-syntax #f) +(define-public define-syntax sc-macro) +(define-public eval-when sc-macro) +(define-public fluid-let-syntax sc-macro) (define-public free-identifier=? #f) (define-public generate-temporaries #f) (define-public identifier? #f) -(define-public identifier-syntax #f) -(define-public let-syntax #f) -(define-public letrec-syntax #f) -(define-public syntax #f) -(define-public syntax-case #f) +(define-public identifier-syntax sc-macro) +(define-public let-syntax sc-macro) +(define-public letrec-syntax sc-macro) +(define-public syntax sc-macro) +(define-public syntax-case sc-macro) (define-public syntax-object->datum #f) -(define-public syntax-rules #f) -(define-public with-syntax #f) +(define-public syntax-rules sc-macro) +(define-public with-syntax sc-macro) +(define-public include sc-macro) + +(define primitive-syntax '(quote lambda letrec if set! begin define or + and let let* cond do quasiquote unquote + unquote-splicing case)) +(for-each (lambda (symbol) + (set-symbol-property! symbol 'primitive-syntax #t)) + primitive-syntax) ;;; Hooks needed by the syntax-case macro package @@ -74,17 +90,29 @@ (list why what) '()))) +(define the-syncase-module (current-module)) + (define (putprop symbol key binding) (let* ((m (current-module)) (v (or (module-variable m symbol) (module-make-local-var! m symbol)))) + (if (assq 'primitive-syntax (symbol-pref symbol)) + (if (eq? (current-module) the-syncase-module) + (set-object-property! (module-variable the-root-module symbol) + key + binding)) + (variable-set! v sc-macro)) (set-object-property! v key binding))) (define (getprop symbol key) (let* ((m (current-module)) (v (module-variable m symbol))) - (and v (object-property v key)))) + (and v (or (object-property v key) + (let ((root-v (module-local-variable the-root-module symbol))) + (and (equal? root-v v) + (object-property root-v key))))))) +(define generated-symbols (make-weak-key-hash-table 1019)) ;;; Compatibility @@ -109,6 +137,21 @@ (apply consumer (access-values result)) (consumer result)))))) +;;; Utilities + +(define (psyncomp) + (system "mv -f psyntax.pp psyntax.pp~") + (let ((in (open-input-file "psyntax.ss")) + (out (open-output-file "psyntax.pp"))) + (let loop ((x (read in))) + (if (eof-object? x) + (begin + (close-port out) + (close-port in)) + (begin + (write (sc-expand3 x 'c '(compile load eval)) out) + (newline out) + (loop (read in))))))) ;;; Load the preprocessed code @@ -129,10 +172,19 @@ ;;; The following line is necessary only if we start making changes ;; (load-from-path "ice-9/psyntax.ss") +(define internal-eval (nested-ref the-scm-module '(app modules guile eval))) + +(define-public (eval x) + (internal-eval (if (and (pair? x) + (string=? (car x) "noexpand")) + (cadr x) + (sc-expand x)))) -;;; Setup some hooks for the module system and the evaluator +;;; Hack to make syncase macros work in the slib module +(let ((m (nested-ref the-root-module '(app modules ice-9 slib)))) + (if m + (set-object-property! (module-local-variable m 'define) + '*sc-expander* + '(define)))) -(variable-set! (builtin-variable 'sc-interface) - (module-public-interface (current-module))) -(variable-set! (builtin-variable 'sc-expand) sc-expand) -(variable-set! (builtin-variable 'scm:eval-transformer) #f) +(define-public syncase sc-expand) |