mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-13 07:10:20 +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>
|
Fri Sep 5 03:09:09 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
|
||||||
|
|
||||||
* emacs.scm (emacs-load): Added new parameter `module'.
|
* emacs.scm (emacs-load): Added new parameter `module'.
|
||||||
|
|
|
||||||
|
|
@ -1258,7 +1258,8 @@
|
||||||
;; bindings that would otherwise not be found locally in the module.
|
;; bindings that would otherwise not be found locally in the module.
|
||||||
;;
|
;;
|
||||||
(define module-type
|
(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))
|
%print-module))
|
||||||
|
|
||||||
;; make-module &opt size uses binder
|
;; make-module &opt size uses binder
|
||||||
|
|
@ -1291,7 +1292,7 @@
|
||||||
"Lazy-binder expected to be a procedure or #f." binder))
|
"Lazy-binder expected to be a procedure or #f." binder))
|
||||||
|
|
||||||
(let ((module (module-constructor (make-vector size '())
|
(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,
|
;; We can't pass this as an argument to module-constructor,
|
||||||
;; because we need it to close over a pointer to the module
|
;; 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 set-module-binder! (record-modifier module-type 'binder))
|
||||||
(define module-eval-closure (record-accessor module-type 'eval-closure))
|
(define module-eval-closure (record-accessor module-type 'eval-closure))
|
||||||
(define set-module-eval-closure! (record-modifier 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 module-name (record-accessor module-type 'name))
|
||||||
(define set-module-name! (record-modifier module-type 'name))
|
(define set-module-name! (record-modifier module-type 'name))
|
||||||
(define module-kind (record-accessor module-type 'kind))
|
(define module-kind (record-accessor module-type 'kind))
|
||||||
|
|
@ -1622,27 +1625,21 @@
|
||||||
;;
|
;;
|
||||||
(define the-module #f)
|
(define the-module #f)
|
||||||
|
|
||||||
;; Syntax case macro support
|
;; scm:eval-transformer
|
||||||
;;
|
;;
|
||||||
(define sc-interface #f)
|
(define scm:eval-transformer #f)
|
||||||
(define sc-expand #f)
|
|
||||||
|
|
||||||
;; set-current-module module
|
;; set-current-module module
|
||||||
;;
|
;;
|
||||||
;; set the current module as viewed by the normalizer.
|
;; set the current module as viewed by the normalizer.
|
||||||
;;
|
;;
|
||||||
(define (set-current-module m)
|
(define (set-current-module m)
|
||||||
(let ((from-sc-module? (and the-module
|
(set! the-module m)
|
||||||
(memq sc-interface (module-uses the-module))))
|
(if m
|
||||||
(to-sc-module? (and m
|
(begin
|
||||||
(memq sc-interface (module-uses m)))))
|
(set! *top-level-lookup-closure* (module-eval-closure the-module))
|
||||||
(set! the-module m)
|
(set! scm:eval-transformer (module-transformer the-module)))
|
||||||
(if from-sc-module? (set! scm:eval-transformer #f))
|
(set! *top-level-lookup-closure* #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))))
|
|
||||||
|
|
||||||
|
|
||||||
;; current-module
|
;; current-module
|
||||||
|
|
@ -1726,10 +1723,7 @@
|
||||||
;;
|
;;
|
||||||
(define (module-use! module interface)
|
(define (module-use! module interface)
|
||||||
(set-module-uses! module
|
(set-module-uses! module
|
||||||
(cons interface (delq! interface (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)))
|
|
||||||
|
|
||||||
|
|
||||||
;;; {Recursive Namespaces}
|
;;; {Recursive Namespaces}
|
||||||
|
|
@ -2128,6 +2122,12 @@
|
||||||
;;; {Macros}
|
;;; {Macros}
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
|
(define (primitive-macro? m)
|
||||||
|
(and (macro? m)
|
||||||
|
(not (macro-transformer m))))
|
||||||
|
|
||||||
|
;;; {Defmacros}
|
||||||
|
;;;
|
||||||
(define macro-table (make-weak-key-hash-table 523))
|
(define macro-table (make-weak-key-hash-table 523))
|
||||||
(define xformer-table (make-weak-key-hash-table 523))
|
(define xformer-table (make-weak-key-hash-table 523))
|
||||||
|
|
||||||
|
|
@ -2565,6 +2565,10 @@
|
||||||
(defmacro use-modules modules
|
(defmacro use-modules modules
|
||||||
`(process-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)
|
(define define-private define)
|
||||||
|
|
||||||
(defmacro define-public args
|
(defmacro define-public args
|
||||||
|
|
|
||||||
128
ice-9/psyntax.ss
128
ice-9/psyntax.ss
|
|
@ -379,6 +379,18 @@
|
||||||
(car exps)
|
(car exps)
|
||||||
`(begin ,@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
|
(define build-letrec
|
||||||
(lambda (src vars val-exps body-exp)
|
(lambda (src vars val-exps body-exp)
|
||||||
(if (null? vars)
|
(if (null? vars)
|
||||||
|
|
@ -387,13 +399,13 @@
|
||||||
|
|
||||||
(define-syntax build-lexical-var
|
(define-syntax build-lexical-var
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ src id) (gensym))))
|
((_ src id) (gensym id generated-symbols))))
|
||||||
|
|
||||||
(define-syntax self-evaluating?
|
(define-syntax self-evaluating?
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ e)
|
((_ e)
|
||||||
(let ((x 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))
|
(define-structure (syntax-object expression wrap))
|
||||||
|
|
@ -1593,6 +1605,37 @@
|
||||||
(lambda (vars body) (build-lambda s vars body)))))))
|
(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
|
(global-extend 'core 'letrec
|
||||||
(lambda (e r w s)
|
(lambda (e r w s)
|
||||||
(syntax-case e ()
|
(syntax-case e ()
|
||||||
|
|
@ -1610,21 +1653,6 @@
|
||||||
(chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
|
(chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
|
||||||
(_ (syntax-error (source-wrap e w s))))))
|
(_ (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!
|
(global-extend 'core 'set!
|
||||||
(lambda (e r w s)
|
(lambda (e r w s)
|
||||||
|
|
@ -1800,6 +1828,19 @@
|
||||||
(cadr x)
|
(cadr x)
|
||||||
(chi-top x null-env top-wrap m esew)))))
|
(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?
|
(set! identifier?
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(nonsymbol-id? x)))
|
(nonsymbol-id? x)))
|
||||||
|
|
@ -1984,32 +2025,6 @@
|
||||||
((dummy . pattern) (syntax template))
|
((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*
|
(define-syntax let*
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(syntax-case x ()
|
(syntax-case x ()
|
||||||
|
|
@ -2022,25 +2037,6 @@
|
||||||
(binding (car bindings)))
|
(binding (car bindings)))
|
||||||
(syntax (let (binding) body)))))))))
|
(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
|
(define-syntax do
|
||||||
(lambda (orig-x)
|
(lambda (orig-x)
|
||||||
(syntax-case orig-x ()
|
(syntax-case orig-x ()
|
||||||
|
|
@ -2136,16 +2132,16 @@
|
||||||
(syntax-case x ()
|
(syntax-case x ()
|
||||||
((_ e)
|
((_ e)
|
||||||
(error 'unquote
|
(error 'unquote
|
||||||
"expression ,~s not valid outside of quasiquote"
|
"expression ,~s not valid outside of quasiquote"
|
||||||
(syntax-object->datum (syntax e)))))))
|
(syntax-object->datum (syntax e)))))))
|
||||||
|
|
||||||
(define-syntax unquote-splicing
|
(define-syntax unquote-splicing
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(syntax-case x ()
|
(syntax-case x ()
|
||||||
((_ e)
|
((_ e)
|
||||||
(error 'unquote-splicing
|
(error 'unquote-splicing
|
||||||
"expression ,@~s not valid outside of quasiquote"
|
"expression ,@~s not valid outside of quasiquote"
|
||||||
(syntax-object->datum (syntax e)))))))
|
(syntax-object->datum (syntax e)))))))
|
||||||
|
|
||||||
(define-syntax case
|
(define-syntax case
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
|
|
|
||||||
|
|
@ -173,6 +173,12 @@
|
||||||
`(define-public ,@(cdr exp))
|
`(define-public ,@(cdr exp))
|
||||||
`(%system-define ,@(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)
|
(define (software-type) 'UNIX)
|
||||||
|
|
||||||
(slib:load (in-vicinity (library-vicinity) "require.scm"))
|
(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
|
;;; Exported variables
|
||||||
|
|
||||||
|
(define-public sc-expand #f)
|
||||||
|
(define-public sc-expand3 #f)
|
||||||
(define-public install-global-transformer #f)
|
(define-public install-global-transformer #f)
|
||||||
(define-public syntax-dispatch #f)
|
(define-public syntax-dispatch #f)
|
||||||
(define-public syntax-error #f)
|
(define-public syntax-error #f)
|
||||||
|
|
||||||
(define-public bound-identifier=? #f)
|
(define-public bound-identifier=? #f)
|
||||||
(define-public datum->syntax-object #f)
|
(define-public datum->syntax-object #f)
|
||||||
(define-public define-syntax #f)
|
(define-public define-syntax sc-macro)
|
||||||
(define-public fluid-let-syntax #f)
|
(define-public eval-when sc-macro)
|
||||||
|
(define-public fluid-let-syntax sc-macro)
|
||||||
(define-public free-identifier=? #f)
|
(define-public free-identifier=? #f)
|
||||||
(define-public generate-temporaries #f)
|
(define-public generate-temporaries #f)
|
||||||
(define-public identifier? #f)
|
(define-public identifier? #f)
|
||||||
(define-public identifier-syntax #f)
|
(define-public identifier-syntax sc-macro)
|
||||||
(define-public let-syntax #f)
|
(define-public let-syntax sc-macro)
|
||||||
(define-public letrec-syntax #f)
|
(define-public letrec-syntax sc-macro)
|
||||||
(define-public syntax #f)
|
(define-public syntax sc-macro)
|
||||||
(define-public syntax-case #f)
|
(define-public syntax-case sc-macro)
|
||||||
(define-public syntax-object->datum #f)
|
(define-public syntax-object->datum #f)
|
||||||
(define-public syntax-rules #f)
|
(define-public syntax-rules sc-macro)
|
||||||
(define-public with-syntax #f)
|
(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
|
;;; Hooks needed by the syntax-case macro package
|
||||||
|
|
||||||
|
|
@ -74,17 +90,29 @@
|
||||||
(list why what)
|
(list why what)
|
||||||
'())))
|
'())))
|
||||||
|
|
||||||
|
(define the-syncase-module (current-module))
|
||||||
|
|
||||||
(define (putprop symbol key binding)
|
(define (putprop symbol key binding)
|
||||||
(let* ((m (current-module))
|
(let* ((m (current-module))
|
||||||
(v (or (module-variable m symbol)
|
(v (or (module-variable m symbol)
|
||||||
(module-make-local-var! 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)))
|
(set-object-property! v key binding)))
|
||||||
|
|
||||||
(define (getprop symbol key)
|
(define (getprop symbol key)
|
||||||
(let* ((m (current-module))
|
(let* ((m (current-module))
|
||||||
(v (module-variable m symbol)))
|
(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
|
;;; Compatibility
|
||||||
|
|
||||||
|
|
@ -109,6 +137,21 @@
|
||||||
(apply consumer (access-values result))
|
(apply consumer (access-values result))
|
||||||
(consumer 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
|
;;; Load the preprocessed code
|
||||||
|
|
||||||
|
|
@ -129,10 +172,19 @@
|
||||||
;;; The following line is necessary only if we start making changes
|
;;; The following line is necessary only if we start making changes
|
||||||
;; (load-from-path "ice-9/psyntax.ss")
|
;; (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)
|
;;; Hack to make syncase macros work in the slib module
|
||||||
(module-public-interface (current-module)))
|
(let ((m (nested-ref the-root-module '(app modules ice-9 slib))))
|
||||||
(variable-set! (builtin-variable 'sc-expand) sc-expand)
|
(if m
|
||||||
(variable-set! (builtin-variable 'scm:eval-transformer) #f)
|
(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