1 ;;;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
3 ;;;; This library is free software; you can redistribute it and/or
4 ;;;; modify it under the terms of the GNU Lesser General Public
5 ;;;; License as published by the Free Software Foundation; either
6 ;;;; version 2.1 of the License, or (at your option) any later version.
8 ;;;; This library is distributed in the hope that it will be useful,
9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 ;;;; Lesser General Public License for more details.
13 ;;;; You should have received a copy of the GNU Lesser General Public
14 ;;;; License along with this library; if not, write to the Free Software
15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (define-module (ice-9 syncase)
20 :use-module (ice-9 debug)
21 :use-module (ice-9 threads)
22 :export-syntax (sc-macro define-syntax define-syntax-public
23 eval-when fluid-let-syntax
24 identifier-syntax let-syntax
25 letrec-syntax syntax syntax-case syntax-rules
28 :export (sc-expand sc-expand3 install-global-transformer
29 syntax-dispatch syntax-error bound-identifier=?
30 datum->syntax-object free-identifier=?
31 generate-temporaries identifier? syntax-object->datum
37 (define expansion-eval-closure (make-fluid))
38 (define (current-eval-closure)
39 (or (fluid-ref expansion-eval-closure)
40 (module-eval-closure (current-module))))
42 (define (env->eval-closure env)
43 (and env (car (last-pair env))))
45 (define (annotation? x) #f)
48 (procedure->memoizing-macro
50 (with-fluids ((expansion-eval-closure (env->eval-closure env)))
53 ;;; Exported variables
56 (define sc-expand3 #f)
58 (define install-global-transformer #f)
59 (define syntax-dispatch #f)
60 (define syntax-error #f)
62 (define bound-identifier=? #f)
63 (define datum->syntax-object #f)
64 (define free-identifier=? #f)
65 (define generate-temporaries #f)
66 (define identifier? #f)
67 (define syntax-object->datum #f)
69 (define primitive-syntax '(quote lambda letrec if set! begin define or
70 and let let* cond do quasiquote unquote
71 unquote-splicing case))
73 (for-each (lambda (symbol)
74 (set-symbol-property! symbol 'primitive-syntax #t))
77 ;;; Hooks needed by the syntax-case macro package
79 (define (void) *unspecified*)
82 (lambda (f first . rest)
85 (let andmap ((first first))
86 (let ((x (car first)) (first (cdr first)))
89 (and (f x) (andmap first)))))
90 (let andmap ((first first) (rest rest))
94 (rest (map cdr rest)))
97 (and (apply f (cons x xr)) (andmap first rest)))))))))
99 (define (error who format-string why what)
100 (start-stack 'syncase-stack
101 (scm-error 'misc-error
107 (define the-syncase-module (current-module))
108 (define the-syncase-eval-closure (module-eval-closure the-syncase-module))
110 (fluid-set! expansion-eval-closure the-syncase-eval-closure)
112 (define (putprop symbol key binding)
113 (let* ((eval-closure (current-eval-closure))
114 ;; Why not simply do (eval-closure symbol #t)?
115 ;; Answer: That would overwrite imported bindings
116 (v (or (eval-closure symbol #f) ;lookup
117 (eval-closure symbol #t) ;create it locally
119 ;; Don't destroy Guile macros corresponding to
120 ;; primitive syntax when syncase boots.
121 (if (not (and (symbol-property symbol 'primitive-syntax)
122 (eq? eval-closure the-syncase-eval-closure)))
123 (variable-set! v sc-macro))
124 ;; Properties are tied to variable objects
125 (set-object-property! v key binding)))
127 (define (getprop symbol key)
128 (let* ((v ((current-eval-closure) symbol #f)))
130 (or (object-property v key)
131 (and (variable-bound? v)
132 (macro? (variable-ref v))
133 (macro-transformer (variable-ref v)) ;non-primitive
137 (cons 'external-macro
139 (let ((e (syntax-object->datum e)))
141 ;; pass the expression through
143 (let* ((eval-closure (current-eval-closure))
144 (m (variable-ref (eval-closure (car e) #f))))
145 (if (eq? (macro-type m) 'syntax)
146 ;; pass the expression through
148 ;; perform Guile macro transform
149 (let ((e ((macro-transformer m)
151 (append r (list eval-closure)))))
154 (sc-chi e r w))))))))))
156 (define generated-symbols (make-weak-key-hash-table 1019))
158 ;; We define our own gensym here because the Guile built-in one will
159 ;; eventually produce uninterned and unreadable symbols (as needed for
160 ;; safe macro expansions) and will the be inappropriate for dumping to
163 ;; syncase is supposed to only require that gensym produce unique
164 ;; readable symbols, and they only need be unique with respect to
165 ;; multiple calls to gensym, not globally unique.
171 (if (provided? 'threads)
172 (let ((symlock (make-mutex)))
176 (set! result counter)
177 (set! counter (+ counter 1)))
179 ;; faster, non-threaded case.
181 (let ((result counter))
182 (set! counter (+ counter 1))
185 ;; actual gensym body code.
187 (let* ((next-val (next-id))
188 (valstr (number->string next-val)))
191 (string->symbol (string-append "syntmp-" valstr)))
193 (string->symbol (string-append "syntmp-" (car rest) "-" valstr)))
197 "syncase's gensym expected 0 or 1 arguments, got "
198 (length rest)))))))))
200 ;;; Load the preprocessed code
204 (dynamic-wind (lambda ()
205 (set! old-debug (debug-options))
206 (set! old-read (read-options)))
208 (debug-disable 'debug 'procnames)
209 (read-disable 'positions)
210 (load-from-path "ice-9/psyntax-pp"))
212 (debug-options old-debug)
213 (read-options old-read))))
216 ;;; The following lines are necessary only if we start making changes
217 ;; (use-syntax sc-expand)
218 ;; (load-from-path "ice-9/psyntax")
220 (define internal-eval (nested-ref the-scm-module '(%app modules guile eval)))
222 (define (eval x environment)
223 (internal-eval (if (and (pair? x)
224 (equal? (car x) "noexpand"))
229 ;;; Hack to make syncase macros work in the slib module
230 (let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
232 (set-object-property! (module-local-variable m 'define)
236 (define (syncase exp)
237 (with-fluids ((expansion-eval-closure
238 (module-eval-closure (current-module))))
241 (set-module-transformer! the-syncase-module syncase)
243 (define-syntax define-syntax-public
247 ;(eval-case ((load-toplevel) (export-syntax name)))
248 (define-syntax name rules ...)))))
250 (fluid-set! expansion-eval-closure #f)