-;;;; Copyright (C) 1997, 2000, 2001 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
-;;;; This program is distributed in the hope that it will be useful,
+;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
-;;;;
-;;;; As a special exception, the Free Software Foundation gives permission
-;;;; for additional uses of the text contained in its release of GUILE.
-;;;;
-;;;; The exception is that, if you link the GUILE library with other files
-;;;; to produce an executable, this does not by itself cause the
-;;;; resulting executable to be covered by the GNU General Public License.
-;;;; Your use of that executable is in no way restricted on account of
-;;;; linking the GUILE library code into it.
-;;;;
-;;;; This exception does not however invalidate any other reasons why
-;;;; the executable file might be covered by the GNU General Public License.
-;;;;
-;;;; This exception applies only to the code released by the
-;;;; Free Software Foundation under the name GUILE. If you copy
-;;;; code from other Free Software Foundation releases into a copy of
-;;;; GUILE, as the General Public License permits, the exception does
-;;;; not apply to the code that you add in this way. To avoid misleading
-;;;; anyone as to the status of such modified files, you must delete
-;;;; this exception notice from them.
-;;;;
-;;;; If you write modifications of your own for GUILE, it is your choice
-;;;; whether to permit this exception to apply to your modifications.
-;;;; If you do not wish that, delete this exception notice.
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
\f
(define-module (ice-9 syncase)
:use-module (ice-9 debug)
:use-module (ice-9 threads)
- :export-syntax (sc-macro define-syntax eval-when fluid-let-syntax
+ :export-syntax (sc-macro define-syntax define-syntax-public
+ eval-when fluid-let-syntax
identifier-syntax let-syntax
letrec-syntax syntax syntax-case syntax-rules
with-syntax
syntax-dispatch syntax-error bound-identifier=?
datum->syntax-object free-identifier=?
generate-temporaries identifier? syntax-object->datum
- void eval syncase))
+ void syncase)
+ :replace (eval))
\f
(with-fluids ((expansion-eval-closure (env->eval-closure env)))
(sc-expand exp)))))
-(fluid-set! expansion-eval-closure (env->eval-closure #f))
-
;;; Exported variables
(define sc-expand #f)
(define sc-expand3 #f)
+(define sc-chi #f)
(define install-global-transformer #f)
(define syntax-dispatch #f)
(define syntax-error #f)
(define bound-identifier=? #f)
(define datum->syntax-object #f)
-(define define-syntax sc-macro)
-(define eval-when sc-macro)
-(define fluid-let-syntax sc-macro)
(define free-identifier=? #f)
(define generate-temporaries #f)
(define identifier? #f)
-(define identifier-syntax sc-macro)
-(define let-syntax sc-macro)
-(define letrec-syntax sc-macro)
-(define syntax sc-macro)
-(define syntax-case sc-macro)
(define syntax-object->datum #f)
-(define syntax-rules sc-macro)
-(define with-syntax sc-macro)
-(define include sc-macro)
(define primitive-syntax '(quote lambda letrec if set! begin define or
- and let let* cond do quasiquote unquote
- unquote-splicing case))
+ and let let* cond do quasiquote unquote
+ unquote-splicing case))
(for-each (lambda (symbol)
(set-symbol-property! symbol 'primitive-syntax #t))
(define the-syncase-module (current-module))
(define the-syncase-eval-closure (module-eval-closure the-syncase-module))
+(fluid-set! expansion-eval-closure the-syncase-eval-closure)
+
(define (putprop symbol key binding)
- (let* ((v ((fluid-ref expansion-eval-closure) symbol #t)))
- (if (symbol-property symbol 'primitive-syntax)
- (if (eq? (fluid-ref expansion-eval-closure) the-syncase-eval-closure)
- (set-object-property! (module-variable the-root-module symbol)
- key
- binding))
+ (let* ((eval-closure (fluid-ref expansion-eval-closure))
+ ;; Why not simply do (eval-closure symbol #t)?
+ ;; Answer: That would overwrite imported bindings
+ (v (or (eval-closure symbol #f) ;lookup
+ (eval-closure symbol #t) ;create it locally
+ )))
+ ;; Don't destroy Guile macros corresponding to
+ ;; primitive syntax when syncase boots.
+ (if (not (and (symbol-property symbol 'primitive-syntax)
+ (eq? eval-closure the-syncase-eval-closure)))
(variable-set! v sc-macro))
+ ;; Properties are tied to variable objects
(set-object-property! v key binding)))
(define (getprop symbol key)
(let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
- (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)))))))
+ (and v
+ (or (object-property v key)
+ (and (variable-bound? v)
+ (macro? (variable-ref v))
+ (macro-transformer (variable-ref v)) ;non-primitive
+ guile-macro)))))
+
+(define guile-macro
+ (cons 'external-macro
+ (lambda (e r w s)
+ (let ((e (syntax-object->datum e)))
+ (if (symbol? e)
+ ;; pass the expression through
+ e
+ (let* ((eval-closure (fluid-ref expansion-eval-closure))
+ (m (variable-ref (eval-closure (car e) #f))))
+ (if (eq? (macro-type m) 'syntax)
+ ;; pass the expression through
+ e
+ ;; perform Guile macro transform
+ (let ((e ((macro-transformer m)
+ e
+ (append r (list eval-closure)))))
+ (if (variable? e)
+ e
+ (if (null? r)
+ (sc-expand e)
+ (sc-chi e r w)))))))))))
(define generated-symbols (make-weak-key-hash-table 1019))
;; (use-syntax sc-expand)
;; (load-from-path "ice-9/psyntax.ss")
-(define internal-eval (nested-ref the-scm-module '(app modules guile eval)))
+(define internal-eval (nested-ref the-scm-module '(%app modules guile eval)))
(define (eval x environment)
(internal-eval (if (and (pair? x)
environment))
;;; Hack to make syncase macros work in the slib module
-(let ((m (nested-ref the-root-module '(app modules ice-9 slib))))
+(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 syncase sc-expand)
+(define (syncase exp)
+ (with-fluids ((expansion-eval-closure
+ (module-eval-closure (current-module))))
+ (sc-expand exp)))
+
+(set-module-transformer! the-syncase-module syncase)
+
+(define-syntax define-syntax-public
+ (syntax-rules ()
+ ((_ name rules ...)
+ (begin
+ ;(eval-case ((load-toplevel) (export-syntax name)))
+ (define-syntax name rules ...)))))
+
+(fluid-set! expansion-eval-closure (env->eval-closure #f))
HCoop / bpt / guile.git / blobdiff