X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/1f355b4f35c9fc0b67866bcd8be01642fade614f..fdc0a82263cb3793cb92d802431162a50f12674c:/ice-9/syncase.scm

diff --git a/ice-9/syncase.scm b/ice-9/syncase.scm
dissimilarity index 63%
index b5b20a984..d3e5bb591 100644
--- a/ice-9/syncase.scm
+++ b/ice-9/syncase.scm
@@ -1,128 +1,248 @@
-;;;; 	Copyright (C) 1997 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 program 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.
-;;;; 
-;;;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;; 
-
-
-(define-module (ice-9 syncase)
-  :use-module (ice-9 debug))
-
-
-
-(define-public (void) *unspecified*)
-
-(define andmap
-  (lambda (f first . rest)
-    (or (null? first)
-        (if (null? rest)
-            (let andmap ((first first))
-              (let ((x (car first)) (first (cdr first)))
-                (if (null? first)
-                    (f x)
-                    (and (f x) (andmap first)))))
-            (let andmap ((first first) (rest rest))
-              (let ((x (car first))
-                    (xr (map car rest))
-                    (first (cdr first))
-                    (rest (map cdr rest)))
-                (if (null? first)
-                    (apply f (cons x xr))
-                    (and (apply f (cons x xr)) (andmap first rest)))))))))
-
-(define (error who format-string why what)
-  (start-stack 'syncase-stack
-	       (scm-error 'misc-error
-			  who
-			  "%s %S"
-			  (list why what)
-			  '())))
-
-(define (putprop s p v)
-  (builtin-variable s)
-  (set-symbol-property! s p v))
-(define getprop symbol-property)
-
-(define-public sc-expand #f)
-(define-public install-global-transformer #f)
-(define-public syntax-dispatch #f)
-(define-public syntax-error #f)
-
-;;;*fixme* builtin-variable
-(define-public bound-identifier=? #f)
-(define-public datum->syntax-object #f)
-(builtin-variable 'define-syntax)
-(builtin-variable 'fluid-let-syntax)
-(define-public free-identifier=? #f)
-(define-public generate-temporaries #f)
-(define-public identifier? #f)
-(builtin-variable 'identifier-syntax)
-(builtin-variable 'let-syntax)
-(builtin-variable 'letrec-syntax)
-(builtin-variable 'syntax)
-(builtin-variable 'syntax-case)
-(define-public syntax-object->datum #f)
-(builtin-variable 'syntax-rules)
-(builtin-variable 'with-syntax)
-
-;;; Compatibility
-
-(define values:*values-rtd*
-  (make-record-type "values"
-		    '(values)))
-
-(define values
-  (let ((make-values (record-constructor values:*values-rtd*)))
-    (lambda x
-      (if (and (not (null? x))
-	       (null? (cdr x)))
-	  (car x)
-	  (make-values x)))))
-
-(define call-with-values
-  (let ((access-values (record-accessor values:*values-rtd* 'values))
-	(values-predicate? (record-predicate values:*values-rtd*)))
-    (lambda (producer consumer)
-      (let ((result (producer)))
-	(if (values-predicate? result)
-	    (apply consumer (access-values result))
-	    (consumer result))))))
-
-(let ((old-debug #f)
-      (old-read #f))
-  (dynamic-wind (lambda ()
-		  (set! old-debug (debug-options))
-		  (set! old-read (read-options)))
-		(lambda ()
-		  (debug-disable 'debug 'procnames)
-		  (read-disable 'positions)
-		  (load-from-path "ice-9/psyntax.pp"))
-		(lambda ()
-		  (debug-options old-debug)
-		  (read-options old-read))))
-
-;; The followin line is necessary only if we start making changes
-;; (load-from-path "ice-9/psyntax.ss")
-
-(define-public (eval-options . args)
-  '())
-
-;;; *fixme*
-(define-public (eval-enable x)
-  (variable-set! (builtin-variable 'scm:eval-transformer) sc-expand))
-
-(define-public (eval-disable x)
-  (variable-set! (builtin-variable 'scm:eval-transformer) #f))
-
-(eval-enable 'syncase)
+;;;; 	Copyright (C) 1997, 2000, 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
+;;;; 
+;;;; 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 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
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; 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
+;;;; 
+
+
+(define-module (ice-9 syncase)
+  :use-module (ice-9 debug)
+  :use-module (ice-9 threads)
+  :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
+		  include)
+  :export (sc-expand sc-expand3 install-global-transformer
+	   syntax-dispatch syntax-error bound-identifier=?
+	   datum->syntax-object free-identifier=?
+	   generate-temporaries identifier? syntax-object->datum
+	   void syncase)
+  :replace (eval))
+
+
+
+(define expansion-eval-closure (make-fluid))
+(define (current-eval-closure)
+  (or (fluid-ref expansion-eval-closure)
+      (module-eval-closure (current-module))))
+
+(define (env->eval-closure env)
+  (and env (car (last-pair env))))
+
+(define sc-macro
+  (procedure->memoizing-macro
+    (lambda (exp env)
+      (with-fluids ((expansion-eval-closure (env->eval-closure env)))
+        (sc-expand exp)))))
+
+;;; 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 free-identifier=? #f)
+(define generate-temporaries #f)
+(define identifier? #f)
+(define syntax-object->datum #f)
+
+(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
+
+(define (void) *unspecified*)
+
+(define andmap
+  (lambda (f first . rest)
+    (or (null? first)
+        (if (null? rest)
+            (let andmap ((first first))
+              (let ((x (car first)) (first (cdr first)))
+                (if (null? first)
+                    (f x)
+                    (and (f x) (andmap first)))))
+            (let andmap ((first first) (rest rest))
+              (let ((x (car first))
+                    (xr (map car rest))
+                    (first (cdr first))
+                    (rest (map cdr rest)))
+                (if (null? first)
+                    (apply f (cons x xr))
+                    (and (apply f (cons x xr)) (andmap first rest)))))))))
+
+(define (error who format-string why what)
+  (start-stack 'syncase-stack
+	       (scm-error 'misc-error
+			  who
+			  "~A ~S"
+			  (list why what)
+			  '())))
+
+(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* ((eval-closure (current-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 ((current-eval-closure) symbol #f)))
+    (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 (current-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 (null? r)
+			    (sc-expand e)
+			    (sc-chi e r w))))))))))
+
+(define generated-symbols (make-weak-key-hash-table 1019))
+
+;; We define our own gensym here because the Guile built-in one will
+;; eventually produce uninterned and unreadable symbols (as needed for
+;; safe macro expansions) and will the be inappropriate for dumping to
+;; pssyntax.pp.
+;;
+;; syncase is supposed to only require that gensym produce unique
+;; readable symbols, and they only need be unique with respect to
+;; multiple calls to gensym, not globally unique.
+;;
+(define gensym
+  (let ((counter 0))
+
+    (define next-id
+      (if (provided? 'threads)
+          (let ((symlock (make-mutex)))
+            (lambda ()
+              (let ((result #f))
+                (with-mutex symlock
+                  (set! result counter)
+                  (set! counter (+ counter 1)))
+                result)))
+          ;; faster, non-threaded case.
+          (lambda ()
+            (let ((result counter))
+              (set! counter (+ counter 1))
+              result))))
+    
+    ;; actual gensym body code.
+    (lambda (. rest)
+      (let* ((next-val (next-id))
+             (valstr (number->string next-val)))
+          (cond
+           ((null? rest)
+            (string->symbol (string-append "syntmp-" valstr)))
+           ((null? (cdr rest))
+            (string->symbol (string-append "syntmp-" (car rest) "-" valstr)))
+           (else
+            (error
+             (string-append
+              "syncase's gensym expected 0 or 1 arguments, got "
+              (length rest)))))))))
+
+;;; Load the preprocessed code
+
+(let ((old-debug #f)
+      (old-read #f))
+  (dynamic-wind (lambda ()
+		  (set! old-debug (debug-options))
+		  (set! old-read (read-options)))
+		(lambda ()
+		  (debug-disable 'debug 'procnames)
+		  (read-disable 'positions)
+		  (load-from-path "ice-9/psyntax.pp"))
+		(lambda ()
+		  (debug-options old-debug)
+		  (read-options old-read))))
+
+
+;;; The following lines are necessary only if we start making changes
+;; (use-syntax sc-expand)
+;; (load-from-path "ice-9/psyntax.ss")
+
+(define internal-eval (nested-ref the-scm-module '(%app modules guile eval)))
+
+(define (eval x environment)
+  (internal-eval (if (and (pair? x)
+			  (equal? (car x) "noexpand"))
+		     (cadr x)
+		     (sc-expand x))
+		 environment))
+
+;;; 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 (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 #f)