summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1997-09-10 20:07:04 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1997-09-10 20:07:04 +0000
commit7a0ff2f80714f8c8ece3d8aa53a561dc209f696e (patch)
tree8152d5b235f44d5f2285e65bb0aeeaff4abfed37
parent7332df664494f9a206b2460524f95e8dffe240a4 (diff)
downloadguile-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/ChangeLog45
-rw-r--r--ice-9/boot-9.scm44
-rw-r--r--ice-9/psyntax.ss128
-rw-r--r--ice-9/slib.scm6
-rw-r--r--ice-9/syncase.scm82
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)