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 |
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) |
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)) |
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 |
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 |
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)) |
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 |
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) |
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 () |
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 |
|
|