syncase early in boot-9, defmacros in terms of syntax-case -- halfway working

* module/ice-9/boot-9.scm
  (eval-when): Remove, as syncase is going to handle this one for us.
  (sc-expand, sc-expand3, sc-chi, install-global-transformer)
  (syntax-dispatch, syntax-error, annotation?, bound-identifier=?)
  (datum->syntax-object, free-identifier=?, generate-temporaries)
  (identifier?, syntax-object->datum, void, andmap): Oh, ugly of uglies:
  add these exciting definitions to the main environment. Hopefully we
  can pull them back out soon.
  (make-module-ref, resolve-module): Stub these out, as a replacement for
  expand-support.
  (%pre-modules-transformer): Define to sc-expand, so that we are using
  syncase from the very start.
  (defmacro, define-macro): Define in terms of syntax-case.
  (macroexpand, macroexpand-1): Remove, there should be a different way
  to get at this -- though perhaps with the same name.
  (make-module): Make sc-expand the default module-transformer.
  (process-define-module): Issue a deprecation warning when using ice-9
  syncase.
  (primitive-macro?): Remove, no meaning...
  (use-syntax): Deprecate.
  (define-private, define-public, defmacro-public): Rework in terms of
  syntax-rules.

* module/ice-9/syncase.scm: Gut, as syncase is provided by core now.

module/ice-9/boot-9.scm

@@ -131,30 +131,63 @@
   '(guile))
 (define (module-add! module sym var)
   (hashq-set! (%get-pre-modules-obarray) sym var))
+(define sc-macro 'sc-macro)
+(define (make-module-ref mod var public?)
+  (cond
+   ((or (not mod)
+        (eq? mod (module-name (current-module)))
+        (and (not public?)
+             (not (module-variable (resolve-module mod) var))))
+    var)
+   (else
+    (list (if public? '@ '@@) mod var))))
+(define (resolve-module . args)
+  #f)
 
-;; (eval-when (situation...) form...)
+(define sc-expand #f)
-;;
+(define sc-expand3 #f)
-;; Evaluate certain code based on the situation that eval-when is used
+(define sc-chi #f)
-;; in. There are three situations defined.
+(define install-global-transformer #f)
-;;
+(define syntax-dispatch #f)
-;; `load' triggers when a file is loaded via `load', or when a compiled
+(define syntax-error #f)
-;; file is loaded.
+(define (annotation? x) #f)
-;;
-;; `compile' triggers when an expression is compiled.
-;;
-;; `eval' triggers when code is evaluated interactively, as at the REPL
-;; or via the `compile' or `eval' procedures.
 
-;; NB: this macro is only ever expanded by the interpreter. The compiler
+(define bound-identifier=? #f)
-;; notices it and interprets the situations differently.
+(define datum->syntax-object #f)
-(define eval-when
+(define free-identifier=? #f)
-  (procedure->memoizing-macro
+(define generate-temporaries #f)
-   (lambda (exp env)
+(define identifier? #f)
-     (let ((situations (cadr exp))
+(define syntax-object->datum #f)
-           (body (cddr exp)))
+
-       (if (or (memq 'load situations)
+(define (void) (if #f #f))
-               (memq 'eval situations))
+
-           `(begin . ,body))))))
+(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 (syncase-error who format-string why what)
+  (%start-stack 'syncase-stack
+                (lambda ()
+                  (scm-error 'misc-error who "~A ~S" (list why what) '()))))
+
+;; Until the module system is booted, this will be the current expander.
+(primitive-load-path "ice-9/psyntax-pp")
+
+(define %pre-modules-transformer (lambda args (pk 'in args 'out (apply sc-expand args))))
 
 
 
@@ -170,54 +203,23 @@
 ;;; Depends on: features, eval-case
 ;;;
 
-(define macro-table (make-weak-key-hash-table 61))
+(define-syntax define-macro
-(define xformer-table (make-weak-key-hash-table 61))
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (macro . args) . body)
+       (syntax (define-macro macro (lambda args . body))))
+      ((_ macro transformer)
+       (syntax
+        (define-syntax macro
+          (lambda (y)
+            (let ((v (syntax-object->datum y)))
+              (datum->syntax-object y (apply transformer (cdr v)))))))))))
 
-(define (defmacro? m)  (hashq-ref macro-table m))
+(define-syntax defmacro
-(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
+  (lambda (x)
-(define (defmacro-transformer m) (hashq-ref xformer-table m))
+    (syntax-case x ()
-(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))
+      ((_ macro args . body)
-
+       (syntax (define-macro macro (lambda args . body)))))))
-(define defmacro:transformer
-  (lambda (f)
-    (let* ((xform (lambda (exp env)
-		    (copy-tree (apply f (cdr exp)))))
-	   (a (procedure->memoizing-macro xform)))
-      (assert-defmacro?! a)
-      (set-defmacro-transformer! a f)
-      a)))
-
-
-(define defmacro
-  (let ((defmacro-transformer
-	  (lambda (name parms . body)
-	    (let ((transformer `(lambda ,parms ,@body)))
-	      `(eval-when
-                (eval load compile)
-                (define ,name (defmacro:transformer ,transformer)))))))
-    (defmacro:transformer defmacro-transformer)))
-
-
-;; XXX - should the definition of the car really be looked up in the
-;; current module?
-
-(define (macroexpand-1 e)
-  (cond
-   ((pair? e) (let* ((a (car e))
-		     (val (and (symbol? a) (local-ref (list a)))))
-		(if (defmacro? val)
-		    (apply (defmacro-transformer val) (cdr e))
-		    e)))
-   (#t e)))
-
-(define (macroexpand e)
-  (cond
-   ((pair? e) (let* ((a (car e))
-		     (val (and (symbol? a) (local-ref (list a)))))
-		(if (defmacro? val)
-		    (macroexpand (apply (defmacro-transformer val) (cdr e)))
-		    e)))
-   (#t e)))
 
 (provide 'defmacro)
 
@@ -1196,7 +1198,8 @@
 	     "Lazy-binder expected to be a procedure or #f." binder))
 
 	(let ((module (module-constructor (make-hash-table size)
-					  uses binder #f #f #f #f #f
+					  uses binder #f %pre-modules-transformer
+                                          #f #f #f
 					  (make-hash-table %default-import-size)
 					  '()
 					  (make-weak-key-hash-table 31))))
@@ -1837,6 +1840,7 @@
                 already)
                (autoload
                 ;; Try to autoload the module, and recurse.
+                (pk name)
                 (try-load-module name)
                 (resolve-module name #f))
                (else
@@ -2006,23 +2010,34 @@
             ((#:use-module #:use-syntax)
              (or (pair? (cdr kws))
                  (unrecognized kws))
-             (let* ((interface-args (cadr kws))
+             (cond
-                    (interface (apply resolve-interface interface-args)))
+              ((equal? (caadr kws) '(ice-9 syncase))
-               (and (eq? (car kws) #:use-syntax)
+               (issue-deprecation-warning
-                    (or (symbol? (caar interface-args))
+                "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.")
-                        (error "invalid module name for use-syntax"
-                               (car interface-args)))
-                    (set-module-transformer!
-                     module
-                     (module-ref interface
-                                 (car (last-pair (car interface-args)))
-                                 #f)))
                (loop (cddr kws)
-                     (cons interface reversed-interfaces)
+                     reversed-interfaces
                      exports
                      re-exports
                      replacements
-                     autoloads)))
+                     autoloads))
+              (else
+               (let* ((interface-args (cadr kws))
+                      (interface (apply resolve-interface interface-args)))
+                 (and (eq? (car kws) #:use-syntax)
+                      (or (symbol? (caar interface-args))
+                          (error "invalid module name for use-syntax"
+                                 (car interface-args)))
+                      (set-module-transformer!
+                       module
+                       (module-ref interface
+                                   (car (last-pair (car interface-args)))
+                                   #f)))
+                 (loop (cddr kws)
+                       (cons interface reversed-interfaces)
+                       exports
+                       re-exports
+                       replacements
+                       autoloads)))))
             ((#:autoload)
              (or (and (pair? (cdr kws)) (pair? (cddr kws)))
                  (unrecognized kws))
@@ -2678,32 +2693,6 @@ module '(ice-9 q) '(make-q q-length))}."
 	`(with-fluids* (list ,@fluids) (list ,@values)
 		       (lambda () ,@body)))))
 
-
-
-;;; {Macros}
-;;;
-
-;; actually....hobbit might be able to hack these with a little
-;; coaxing
-;;
-
-(define (primitive-macro? m)
-  (and (macro? m)
-       (not (macro-transformer m))))
-
-(defmacro define-macro (first . rest)
-  (let ((name (if (symbol? first) first (car first)))
-	(transformer
-	 (if (symbol? first)
-	     (car rest)
-	     `(lambda ,(cdr first) ,@rest))))
-    `(eval-when
-      (eval load compile)
-      (define ,name (defmacro:transformer ,transformer)))))
-
-
-
-
 ;;; {While}
 ;;;
 ;;; with `continue' and `break'.
@@ -2843,50 +2832,33 @@ module '(ice-9 q) '(make-q q-length))}."
 (defmacro use-syntax (spec)
   `(eval-when
     (eval load compile)
-     ,@(if (pair? spec)
+    (issue-deprecation-warning
-	   `((process-use-modules (list
+     "`use-syntax' is deprecated. Please contact guile-devel for more info.")
-				   (list ,@(compile-interface-spec spec))))
+    (process-use-modules (list (list ,@(compile-interface-spec spec))))
-	     (set-module-transformer! (current-module)
+    *unspecified*))
-				      ,(car (last-pair spec))))
-	   `((set-module-transformer! (current-module) ,spec)))
-     *unspecified*))
 
 ;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed
 ;; as soon as guile supports hygienic macros.
-(define define-private define)
+(define-syntax define-private
+  (syntax-rules ()
+    ((_ foo bar)
+     (define foo bar))))
 
-(defmacro define-public args
+(define-syntax define-public
-  (define (syntax)
+  (syntax-rules ()
-    (error "bad syntax" (list 'define-public args)))
+    ((_ (name . args) . body)
-  (define (defined-name n)
+     (define-public name (lambda args . body)))
-    (cond
+    ((_ name val)
-     ((symbol? n) n)
+     (begin
-     ((pair? n) (defined-name (car n)))
+       (define name val)
-     (else (syntax))))
+       (export name)))))
-  (cond
-   ((null? args)
-    (syntax))
-   (#t
-    (let ((name (defined-name (car args))))
-      `(begin
-	 (define-private ,@args)
-	 (export ,name))))))
 
-(defmacro defmacro-public args
+(define-syntax defmacro-public
-  (define (syntax)
+  (syntax-rules ()
-    (error "bad syntax" (list 'defmacro-public args)))
+    ((_ name args . body)
-  (define (defined-name n)
+     (begin
-    (cond
+       (defmacro name args . body)
-     ((symbol? n) n)
+       (export-syntax name)))))
-     (else (syntax))))
-  (cond
-   ((null? args)
-    (syntax))
-   (#t
-    (let ((name (defined-name (car args))))
-      `(begin
-	 (export-syntax ,name)
-	 (defmacro ,@args))))))
 
 ;; Export a local variable
 
@@ -3375,6 +3347,12 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;; Place the user in the guile-user module.
 ;;;
 
+;;; FIXME: annotate ?
+;; (define (syncase exp)
+;;   (with-fluids ((expansion-eval-closure
+;; 		 (module-eval-closure (current-module))))
+;;     (deannotate/source-properties (sc-expand (annotate exp)))))
+
 (define-module (guile-user))
 
 ;;; boot-9.scm ends here

module/ice-9/syncase.scm

@@ -17,197 +17,15 @@
 
 
 (define-module (ice-9 syncase)
-  :use-module (ice-9 expand-support)
+  )
-  :use-module (ice-9 debug)
-  :use-module (ice-9 threads)
-  :export-syntax (sc-macro define-syntax define-syntax-public 
-                  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 eval-when))
 
-
+(issue-deprecation-warning
-
+ "Syntax-case macros are now a part of Guile core; importing (ice-9 syncase) is no longer necessary.")
-(define (annotation? x) #f)
-
-(define sc-macro
-  (procedure->memoizing-macro
-    (lambda (exp env)
-      (save-module-excursion
-       (lambda ()
-         ;; Because memoization happens lazily, env's module isn't
-         ;; necessarily the current module.
-         (set-current-module (eval-closure-module (car (last-pair env))))
-         (strip-expansion-structures (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 guile-macro
-  (cons 'external-macro
-	(lambda (e r w s mod)
-	  (let ((e (syntax-object->datum e)))
-	    (if (symbol? e)
-		;; pass the expression through
-		e
-		(let* ((mod (resolve-module mod))
-                       (m (module-ref mod (car e))))
-		  (if (eq? (macro-type m) 'syntax)
-		      ;; pass the expression through
-		      e
-		      ;; perform Guile macro transform
-		      (let ((e ((macro-transformer m)
-				(strip-expansion-structures e)
-				(append r (list (module-eval-closure mod))))))
-			(if (variable? e)
-			    e
-			    (if (null? r)
-				(sc-expand e)
-				(sc-chi e r w (module-name mod))))))))))))
-
-(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))))
-
-(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"))
-		     (strip-expansion-structures (cadr x))
-		     (strip-expansion-structures (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))))
+;; FIXME wingo is this still necessary?
-  (if m
+;; (let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
-      (set-object-property! (module-local-variable m 'define)
+;;   (if m
-			    '*sc-expander*
+;;       (set-object-property! (module-local-variable m 'define)
-			    '(define))))
+;; 			    '*sc-expander*
-
+;; 			    '(define))))
-(define (syncase exp)
-  (strip-expansion-structures (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 ...)))))