mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 22:31:12 +02:00
* * 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.
This commit is contained in:
Mikael Djurfeldt
parent
7332df6644
commit
7a0ff2f807
5 changed files with 204 additions and 101 deletions
|
|
@ -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'.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
128
ice-9/psyntax.ss
128
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)
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
;;; Setup some hooks for the module system and the evaluator
|
||||
(define-public (eval x)
|
||||
(internal-eval (if (and (pair? x)
|
||||
(string=? (car x) "noexpand"))
|
||||
(cadr x)
|
||||
(sc-expand x))))
|
||||
|
||||
(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)
|
||||
;;; 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))))
|
||||
|
||||
(define-public syncase sc-expand)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue