/[guile]/guile/guile-core/ice-9/psyntax.ss
ViewVC logotype

Diff of /guile/guile-core/ice-9/psyntax.ss

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.14 by mvo, Mon Jan 14 20:41:30 2002 UTC revision 1.15 by mdj, Thu Jan 16 11:48:14 2003 UTC
# Line 1  Line 1 
1  ;;;; -*-scheme-*-  ;;;; -*-scheme-*-
2  ;;;;  ;;;;
3  ;;;;    Copyright (C) 2001 Free Software Foundation, Inc.  ;;;;    Copyright (C) 2001, 2003 Free Software Foundation, Inc.
4  ;;;;  ;;;;
5  ;;;; This program is free software; you can redistribute it and/or modify  ;;;; This program is free software; you can redistribute it and/or modify
6  ;;;; it under the terms of the GNU General Public License as published by  ;;;; it under the terms of the GNU General Public License as published by
# Line 418  Line 418 
418      ((_ src name) name)      ((_ src name) name)
419      ((_ src level name) name)))      ((_ src level name) name)))
420    
421  (define-syntax build-data  (define (build-data src exp)
422    (syntax-rules ()    (if (self-evaluating? exp)
423      ((_ src exp) `',exp)))        exp
424          (list 'quote exp)))
425    
426  (define build-sequence  (define build-sequence
427    (lambda (src exps)    (lambda (src exps)
# Line 454  Line 455 
455    (syntax-rules ()    (syntax-rules ()
456      ((_ e)      ((_ e)
457       (let ((x e))       (let ((x e))
458         (or (boolean? x) (number? x) (string? x) (char? x) (null? x) (keyword? x))))))         (or (boolean? x) (number? x) (string? x) (char? x) (keyword? x))))))
459  )  )
460    
461  (define-structure (syntax-object expression wrap))  (define-structure (syntax-object expression wrap))
# Line 504  Line 505 
505    
506  ;;; <binding> ::= (macro . <procedure>)           macros  ;;; <binding> ::= (macro . <procedure>)           macros
507  ;;;               (core . <procedure>)            core forms  ;;;               (core . <procedure>)            core forms
508    ;;;               (external-macro . <procedure>)  external-macro
509  ;;;               (begin)                         begin  ;;;               (begin)                         begin
510  ;;;               (define)                        define  ;;;               (define)                        define
511  ;;;               (define-syntax)                 define-syntax  ;;;               (define-syntax)                 define-syntax
# Line 918  Line 920 
920  ;;;    type                   value         explanation  ;;;    type                   value         explanation
921  ;;;    -------------------------------------------------------------------  ;;;    -------------------------------------------------------------------
922  ;;;    core                   procedure     core form (including singleton)  ;;;    core                   procedure     core form (including singleton)
923    ;;;    external-macro         procedure     external macro
924  ;;;    lexical                name          lexical variable reference  ;;;    lexical                name          lexical variable reference
925  ;;;    global                 name          global variable reference  ;;;    global                 name          global variable reference
926  ;;;    begin                  none          begin keyword  ;;;    begin                  none          begin keyword
# Line 971  Line 974 
974                   ((macro)                   ((macro)
975                    (syntax-type (chi-macro (binding-value b) e r w rib)                    (syntax-type (chi-macro (binding-value b) e r w rib)
976                      r empty-wrap s rib))                      r empty-wrap s rib))
977                   ((core) (values type (binding-value b) e w s))                   ((core external-macro) (values type (binding-value b) e w s))
978                   ((local-syntax)                   ((local-syntax)
979                    (values 'local-syntax-form (binding-value b) e w s))                    (values 'local-syntax-form (binding-value b) e w s))
980                   ((begin) (values 'begin-form #f e w s))                   ((begin) (values 'begin-form #f e w s))
# Line 1077  Line 1080 
1080                        (chi-install-global n (chi e r w))))                        (chi-install-global n (chi e r w))))
1081                  (chi-void)))))                  (chi-void)))))
1082            ((define-form)            ((define-form)
1083             (let ((n (id-var-name value w)))             (let* ((n (id-var-name value w))
1084               (case (binding-type (lookup n r))                    (type (binding-type (lookup n r))))
1085                 (case type
1086                 ((global)                 ((global)
1087                  (eval-if-c&e m                  (eval-if-c&e m
1088                    (build-global-definition s n (chi e r w))))                    (build-global-definition s n (chi e r w))))
1089                 ((displaced-lexical)                 ((displaced-lexical)
1090                  (syntax-error (wrap value w) "identifier out of context"))                  (syntax-error (wrap value w) "identifier out of context"))
1091                 (else (syntax-error (wrap value w)                 (else
1092                         "cannot define keyword at top level")))))                  (if (eq? type 'external-macro)
1093                        (eval-if-c&e m
1094                                     (build-global-definition s n (chi e r w)))
1095                        (syntax-error (wrap value w)
1096                                      "cannot define keyword at top level"))))))
1097            (else (eval-if-c&e m (chi-expr type value e r w s))))))))            (else (eval-if-c&e m (chi-expr type value e r w s))))))))
1098    
1099  (define chi  (define chi
# Line 1100  Line 1108 
1108      (case type      (case type
1109        ((lexical)        ((lexical)
1110         (build-lexical-reference 'value s value))         (build-lexical-reference 'value s value))
1111        ((core) (value e r w s))        ((core external-macro) (value e r w s))
1112        ((lexical-call)        ((lexical-call)
1113         (chi-application         (chi-application
1114           (build-lexical-reference 'fun (source-annotation (car e)) value)           (build-lexical-reference 'fun (source-annotation (car e)) value)
# Line 1351  Line 1359 
1359      (let ((p (local-eval-hook expanded)))      (let ((p (local-eval-hook expanded)))
1360        (if (procedure? p)        (if (procedure? p)
1361            p            p
1362            (syntax-error p "nonprocedure transfomer")))))            (syntax-error p "nonprocedure transformer")))))
1363    
1364  (define chi-void  (define chi-void
1365    (lambda ()    (lambda ()
# Line 2055  Line 2063 
2063         (match* (unannotate (syntax-object-expression e))         (match* (unannotate (syntax-object-expression e))
2064           p (syntax-object-wrap e) '()))           p (syntax-object-wrap e) '()))
2065        (else (match* (unannotate e) p empty-wrap '())))))        (else (match* (unannotate e) p empty-wrap '())))))
2066    
2067    (set! sc-chi chi)
2068  ))  ))
2069  )  )
2070    

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26