The FSF has a new address.

[bpt/guile.git] / ice-9 / psyntax.ss

diff --git a/ice-9/psyntax.ss b/ice-9/psyntax.ss
index ab55a2f..a439d70 100644 (file)
--- a/ice-9/psyntax.ss
+++ b/ice-9/psyntax.ss
@@ -1,21 +1,20 @@
 ;;;; -*-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
-;;;; 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
+;;;; 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
 
@@ -394,9 +393,11 @@
     ((_ src name) name)
     ((_ src level name) name)))
 
-(define-syntax build-data
-  (syntax-rules ()
-    ((_ src exp) `',exp)))
+(define (build-data src exp)
+  (if (and (self-evaluating? exp)
+          (not (vector? exp)))
+      exp
+      (list 'quote exp)))
 
 (define build-sequence
   (lambda (src exps)
@@ -425,12 +426,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))
@@ -480,6 +475,7 @@
 
 ;;; <binding> ::= (macro . <procedure>)           macros
 ;;;               (core . <procedure>)            core forms
+;;;               (external-macro . <procedure>)  external-macro
 ;;;               (begin)                         begin
 ;;;               (define)                        define
 ;;;               (define-syntax)                 define-syntax
@@ -894,6 +890,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
@@ -947,7 +944,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))
@@ -1053,15 +1050,20 @@
                       (chi-install-global n (chi e r w))))
                 (chi-void)))))
           ((define-form)
-           (let ((n (id-var-name value w)))
-             (case (binding-type (lookup n r))
+           (let* ((n (id-var-name value w))
+                 (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)
-                       "cannot define keyword at top level")))))
+               (else
+               (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
@@ -1076,7 +1078,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)
@@ -1327,7 +1329,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 ()
@@ -1877,7 +1879,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
@@ -2032,6 +2033,8 @@
        (match* (unannotate (syntax-object-expression e))
          p (syntax-object-wrap e) '()))
       (else (match* (unannotate e) p empty-wrap '())))))
+
+(set! sc-chi chi)
 ))
 )