* upstream/Makefile.am (ltdl.h.diff, ltdl.c.diff): Look for ltdl.h

and ltdl.c in "$(srcdir)".

* evalext.c, evalext.h (s_scm_self_evaluating_p): Needed by
syntax-case macro fix.

* Makefile.am (c-tokenize.c): Look for it in $(srcdir).

* syncase.scm, psyntax.ss, psyntax.pp: Imported fixes from trunk.

* boot-9.scm (use-syntax): Return *unspecified*.

ice-9/ChangeLog

@@ -1,3 +1,9 @@
+2003-01-27  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+
+	* syncase.scm, psyntax.ss, psyntax.pp: Imported fixes from trunk.
+
+	* boot-9.scm (use-syntax): Return *unspecified*.
+
 2002-12-12  Marius Vollmer  <mvo@zagadka.ping.de>
 
 	* optargs.scm (improper-list-copy): New.

ice-9/boot-9.scm

@@ -1,6 +1,6 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
+;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 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
@@ -2761,8 +2761,8 @@
 	     (set-module-transformer! (current-module)
 				      ,(car (last-pair spec))))
 	   `((set-module-transformer! (current-module) ,spec)))
-     (begin-deprecated
+     (fluid-set! scm:eval-transformer (module-transformer (current-module)))
-      (fluid-set! scm:eval-transformer (module-transformer (current-module)))))
+     *unspecified*)
     (else
      (error "use-syntax can only be used at the top level"))))
 

ice-9/psyntax.ss

@@ -1,6 +1,6 @@
 ;;;; -*-scheme-*-
 ;;;;
-;;;; 	Copyright (C) 2001 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2001, 2003 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
@@ -418,9 +418,11 @@
     ((_ src name) name)
     ((_ src level name) name)))
 
-(define-syntax build-data
+(define (build-data src exp)
-  (syntax-rules ()
+  (if (and (self-evaluating? exp)
-    ((_ src exp) `',exp)))
+	   (not (vector? exp)))
+      exp
+      (list 'quote exp)))
 
 (define build-sequence
   (lambda (src exps)
@@ -449,12 +451,6 @@
 (define-syntax build-lexical-var
   (syntax-rules ()
     ((_ src id) (gensym (symbol->string id)))))
-
-(define-syntax self-evaluating?
-  (syntax-rules ()
-    ((_ e)
-     (let ((x e))
-       (or (boolean? x) (number? x) (string? x) (char? x) (null? x) (keyword? x))))))
 )
 
 (define-structure (syntax-object expression wrap))
@@ -504,6 +500,7 @@
 
 ;;; <binding> ::= (macro . <procedure>)           macros
 ;;;               (core . <procedure>)            core forms
+;;;               (external-macro . <procedure>)  external-macro
 ;;;               (begin)                         begin
 ;;;               (define)                        define
 ;;;               (define-syntax)                 define-syntax
@@ -918,6 +915,7 @@
 ;;;    type                   value         explanation
 ;;;    -------------------------------------------------------------------
 ;;;    core                   procedure     core form (including singleton)
+;;;    external-macro         procedure     external macro
 ;;;    lexical                name          lexical variable reference
 ;;;    global                 name          global variable reference
 ;;;    begin                  none          begin keyword
@@ -971,7 +969,7 @@
                  ((macro)
                   (syntax-type (chi-macro (binding-value b) e r w rib)
                     r empty-wrap s rib))
-                 ((core) (values type (binding-value b) e w s))
+                 ((core external-macro) (values type (binding-value b) e w s))
                  ((local-syntax)
                   (values 'local-syntax-form (binding-value b) e w s))
                  ((begin) (values 'begin-form #f e w s))
@@ -1077,15 +1075,20 @@
                       (chi-install-global n (chi e r w))))
                 (chi-void)))))
           ((define-form)
-           (let ((n (id-var-name value w)))
+           (let* ((n (id-var-name value w))
-             (case (binding-type (lookup n r))
+		  (type (binding-type (lookup n r))))
+             (case type
                ((global)
                 (eval-if-c&e m
                   (build-global-definition s n (chi e r w))))
                ((displaced-lexical)
                 (syntax-error (wrap value w) "identifier out of context"))
-               (else (syntax-error (wrap value w)
+               (else
-                       "cannot define keyword at top level")))))
+		(if (eq? type 'external-macro)
+		    (eval-if-c&e m
+				 (build-global-definition s n (chi e r w)))
+		    (syntax-error (wrap value w)
+				  "cannot define keyword at top level"))))))
           (else (eval-if-c&e m (chi-expr type value e r w s))))))))
 
 (define chi
@@ -1100,7 +1103,7 @@
     (case type
       ((lexical)
        (build-lexical-reference 'value s value))
-      ((core) (value e r w s))
+      ((core external-macro) (value e r w s))
       ((lexical-call)
        (chi-application
          (build-lexical-reference 'fun (source-annotation (car e)) value)
@@ -1351,7 +1354,7 @@
     (let ((p (local-eval-hook expanded)))
       (if (procedure? p)
           p
-          (syntax-error p "nonprocedure transfomer")))))
+          (syntax-error p "nonprocedure transformer")))))
 
 (define chi-void
   (lambda ()
@@ -1901,7 +1904,6 @@
 
 (set! datum->syntax-object
   (lambda (id datum)
-    (arg-check nonsymbol-id? id 'datum->syntax-object)
     (make-syntax-object datum (syntax-object-wrap id))))
 
 (set! syntax-object->datum
@@ -2056,6 +2058,8 @@
        (match* (unannotate (syntax-object-expression e))
          p (syntax-object-wrap e) '()))
       (else (match* (unannotate e) p empty-wrap '())))))
+
+(set! sc-chi chi)
 ))
 )
 

ice-9/syncase.scm

@@ -1,4 +1,4 @@
-;;;; 	Copyright (C) 1997, 2000, 2001 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 1997, 2000, 2001, 2002, 2003 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
@@ -44,7 +44,8 @@
 (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
@@ -65,40 +66,38 @@
 
 
 
+(define expansion-eval-closure (make-fluid))
+
+(define (env->eval-closure env)
+  (or (and env
+	   (car (last-pair env)))
+      (module-eval-closure the-root-module)))
+
 (define sc-macro
   (procedure->memoizing-macro
     (lambda (exp env)
-      (sc-expand exp))))
+      (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 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
+			   and let let* cond do quasiquote unquote
-			      unquote-splicing case))
+			   unquote-splicing case))
 
 (for-each (lambda (symbol)
 	    (set-symbol-property! symbol 'primitive-syntax #t))
@@ -135,26 +134,53 @@
 			  '())))
 
 (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* ((m (current-module))
+  (let* ((eval-closure (fluid-ref expansion-eval-closure))
-	 (v (or (module-variable m symbol)
+	 ;; Why not simply do (eval-closure symbol #t)?
-		(module-make-local-var! m symbol))))
+	 ;; Answer: That would overwrite imported bindings
-    (if (symbol-property symbol 'primitive-syntax)
+	 (v (or (eval-closure symbol #f) ;lookup
-	(if (eq? (current-module) the-syncase-module)
+		(eval-closure symbol #t) ;create it locally
-	    (set-object-property! (module-variable the-root-module symbol)
+		)))
-				  key
+    ;; Don't destroy Guile macros corresponding to
-				  binding))
+    ;; 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* ((m (current-module))
+  (let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
-	 (v (module-variable m symbol)))
+    (and v
-    (and v (or (object-property v key)
+	 (or (object-property v key)
-	       (let ((root-v (module-local-variable the-root-module symbol)))
+	     (and (variable-bound? v)
-		 (and (equal? root-v v)
+		  (macro? (variable-ref v))
-		      (object-property root-v key)))))))
+		  (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 (null? r)
+			    (sc-expand e)
+			    (sc-chi e r w))))))))))
 
 (define generated-symbols (make-weak-key-hash-table 1019))
 
@@ -237,4 +263,18 @@
 			    '*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))

libguile-ltdl/ChangeLog

@@ -1,3 +1,8 @@
+2003-01-27  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+
+	* upstream/Makefile.am (ltdl.h.diff, ltdl.c.diff): Look for ltdl.h
+	and ltdl.c in "$(srcdir)".
+
 2002-10-25  Marius Vollmer  <marius.vollmer@uni-dortmund.de>
 
 	* upstream/ltdl.c: New copy from libtool 1.4.3.

libguile-ltdl/upstream/Makefile.am

@@ -1,6 +1,6 @@
 ## Process this file with Automake to create Makefile.in
 ##
-##  	Copyright (C) 2002 Free Software Foundation, Inc.
+##  	Copyright (C) 2002, 2003 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##
@@ -34,7 +34,7 @@ ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_L
 EXTRA_DIST := ltdl.h ltdl.c ltdl.h.diff ltdl.c.diff
 BUILT_SOURCES := ltdl.h.diff ltdl.c.diff
 
-ltdl.h.diff: ltdl.h $(srcdir)/../raw-ltdl.h
+ltdl.h.diff: $(srcdir)/ltdl.h $(srcdir)/../raw-ltdl.h
 	cp $(srcdir)/../raw-ltdl.h raw-ltdl.guilemod.h.tmp
 	perl -pi \
 	  -e 's/SCMLTXT/extern/go;' \
@@ -43,10 +43,10 @@ ltdl.h.diff: ltdl.h $(srcdir)/../raw-ltdl.h
 	  -e 's/SCM_INSERTED_DLSYMLIST_STRUCT_DECL //go;' \
 	  raw-ltdl.guilemod.h.tmp
 	mv raw-ltdl.guilemod.h.tmp raw-ltdl.guilemod.h
-	diff -ru ltdl.h raw-ltdl.guilemod.h > ltdl.h.diff; \
+	diff -ru $(srcdir)/ltdl.h raw-ltdl.guilemod.h > ltdl.h.diff; \
 	  test "$$?" -eq 1
 
-ltdl.c.diff: ltdl.c $(srcdir)/../raw-ltdl.c
+ltdl.c.diff: $(srcdir)/ltdl.c $(srcdir)/../raw-ltdl.c
 	cp $(srcdir)/../raw-ltdl.c raw-ltdl.guilemod.c.tmp
 	perl -pi \
 	  -e 's/SCMLTXT/extern/go;' \
@@ -55,7 +55,7 @@ ltdl.c.diff: ltdl.c $(srcdir)/../raw-ltdl.c
 	  -e 's/SCM_INSERTED_DLSYMLIST_STRUCT_DECL //go;' \
 	  raw-ltdl.guilemod.c.tmp
 	mv raw-ltdl.guilemod.c.tmp raw-ltdl.guilemod.c
-	diff -ru ltdl.c raw-ltdl.guilemod.c > ltdl.c.diff; \
+	diff -ru $(srcdir)/ltdl.c raw-ltdl.guilemod.c > ltdl.c.diff; \
 	  test "$$?" -eq 1
 
 CLEANFILES := \

libguile/ChangeLog

@@ -1,3 +1,10 @@
+2003-01-27  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+
+	* evalext.c, evalext.h (s_scm_self_evaluating_p): Needed by
+	syntax-case macro fix.
+
+	* Makefile.am (c-tokenize.c): Look for it in $(srcdir).
+
 2003-01-08  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
 
 	* goops.c (scm_sys_prep_layout_x): Bugfix: Only create layout for

libguile/Makefile.am

@@ -1,6 +1,6 @@
 ## Process this file with Automake to create Makefile.in
 ##
-##  	Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
+##  	Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##
@@ -256,8 +256,8 @@ guile-procedures.txt: guile-procedures.texi
 
 endif
 
-c-tokenize.c: c-tokenize.lex
+c-tokenize.c: $(srcdir)/c-tokenize.lex
-	flex -t c-tokenize.lex > $@ || { rm $@; false; }
+	flex -t $(srcdir)/c-tokenize.lex > $@ || { rm $@; false; }
 
 schemelibdir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)
 schemelib_DATA = guile-procedures.txt

libguile/evalext.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001, 2003 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
@@ -143,6 +143,60 @@ scm_m_undefine (SCM x, SCM env)
 
 SCM_REGISTER_PROC (s_map_in_order, "map-in-order", 2, 0, 1, scm_map);
 
+#define scm_tcs_struct scm_tcs_cons_gloc
+
+SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
+	    (SCM obj),
+	    "Return #t for objects which Guile considers self-evaluating")
+#define FUNC_NAME s_scm_self_evaluating_p
+{
+  switch (SCM_ITAG3 (obj))
+    {
+    case scm_tc3_int_1:
+    case scm_tc3_int_2:
+      /* inum */
+      return SCM_BOOL_T;
+    case scm_tc3_imm24:
+	/* characters, booleans, other immediates */
+      return SCM_BOOL (!SCM_NULLP (obj));
+    case scm_tc3_cons:
+      switch (SCM_TYP7 (obj))
+	{
+	case scm_tcs_closures:
+	case scm_tc7_vector:
+	case scm_tc7_wvect:
+#ifdef HAVE_ARRAYS
+	case scm_tc7_bvect:
+	case scm_tc7_byvect:
+	case scm_tc7_svect:
+	case scm_tc7_ivect:
+	case scm_tc7_uvect:
+	case scm_tc7_fvect:
+	case scm_tc7_dvect:
+	case scm_tc7_cvect:
+#ifdef HAVE_LONG_LONGS
+	case scm_tc7_llvect:
+#endif
+#endif
+	case scm_tc7_string:
+	case scm_tc7_smob:
+	case scm_tc7_cclo:
+	case scm_tc7_pws:
+	case scm_tcs_subrs:
+	case scm_tcs_struct:
+	  return SCM_BOOL_T;
+	default:
+	  return SCM_BOOL_F;
+	}
+    }
+  SCM_MISC_ERROR ("Internal error: Object ~S has unknown type",
+		  scm_list_1 (obj));
+  return SCM_UNSPECIFIED; /* never reached */
+}
+#undef FUNC_NAME
+
+#undef scm_tcs_struct
+
 void 
 scm_init_evalext ()
 {

libguile/evalext.h

@@ -2,7 +2,7 @@
 
 #ifndef EVALEXTH
 #define EVALEXTH
-/*	Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+/*	Copyright (C) 1998, 1999, 2000, 2003 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
@@ -51,6 +51,7 @@
 extern SCM scm_m_generalized_set_x (SCM xorig, SCM env);
 extern SCM scm_definedp (SCM sym, SCM env);
 extern SCM scm_m_undefine (SCM x, SCM env);
+extern SCM scm_self_evaluating_p (SCM obj);
 extern void scm_init_evalext (void);
 
 #endif  /* EVALEXTH */