Commit | Line | Data |
---|---|---|
6232c3dd | 1 | ;;;; Copyright (C) 1997, 2000 Free Software Foundation, Inc. |
a63812a2 JB |
2 | ;;;; |
3 | ;;;; This program is free software; you can redistribute it and/or modify | |
4 | ;;;; it under the terms of the GNU General Public License as published by | |
5 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
6 | ;;;; any later version. | |
7 | ;;;; | |
8 | ;;;; This program is distributed in the hope that it will be useful, | |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | ;;;; GNU General Public License for more details. | |
12 | ;;;; | |
13 | ;;;; You should have received a copy of the GNU General Public License | |
14 | ;;;; along with this software; see the file COPYING. If not, write to | |
c6e23ea2 JB |
15 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | ;;;; Boston, MA 02111-1307 USA | |
a63812a2 JB |
17 | ;;;; |
18 | \f | |
19 | ||
20 | (define-module (ice-9 syncase) | |
21 | :use-module (ice-9 debug)) | |
22 | ||
23 | \f | |
24 | ||
25 | (define-public sc-macro | |
26 | (procedure->memoizing-macro | |
27 | (lambda (exp env) | |
28 | (sc-expand exp)))) | |
29 | ||
30 | ;;; Exported variables | |
31 | ||
32 | (define-public sc-expand #f) | |
33 | (define-public sc-expand3 #f) | |
34 | (define-public install-global-transformer #f) | |
35 | (define-public syntax-dispatch #f) | |
36 | (define-public syntax-error #f) | |
37 | ||
38 | (define-public bound-identifier=? #f) | |
39 | (define-public datum->syntax-object #f) | |
40 | (define-public define-syntax sc-macro) | |
41 | (define-public eval-when sc-macro) | |
42 | (define-public fluid-let-syntax sc-macro) | |
43 | (define-public free-identifier=? #f) | |
44 | (define-public generate-temporaries #f) | |
45 | (define-public identifier? #f) | |
46 | (define-public identifier-syntax sc-macro) | |
47 | (define-public let-syntax sc-macro) | |
48 | (define-public letrec-syntax sc-macro) | |
49 | (define-public syntax sc-macro) | |
50 | (define-public syntax-case sc-macro) | |
51 | (define-public syntax-object->datum #f) | |
52 | (define-public syntax-rules sc-macro) | |
53 | (define-public with-syntax sc-macro) | |
54 | (define-public include sc-macro) | |
55 | ||
56 | (define primitive-syntax '(quote lambda letrec if set! begin define or | |
57 | and let let* cond do quasiquote unquote | |
58 | unquote-splicing case)) | |
59 | ||
60 | (for-each (lambda (symbol) | |
61 | (set-symbol-property! symbol 'primitive-syntax #t)) | |
62 | primitive-syntax) | |
63 | ||
64 | ;;; Hooks needed by the syntax-case macro package | |
65 | ||
66 | (define-public (void) *unspecified*) | |
67 | ||
68 | (define andmap | |
69 | (lambda (f first . rest) | |
70 | (or (null? first) | |
71 | (if (null? rest) | |
72 | (let andmap ((first first)) | |
73 | (let ((x (car first)) (first (cdr first))) | |
74 | (if (null? first) | |
75 | (f x) | |
76 | (and (f x) (andmap first))))) | |
77 | (let andmap ((first first) (rest rest)) | |
78 | (let ((x (car first)) | |
79 | (xr (map car rest)) | |
80 | (first (cdr first)) | |
81 | (rest (map cdr rest))) | |
82 | (if (null? first) | |
83 | (apply f (cons x xr)) | |
84 | (and (apply f (cons x xr)) (andmap first rest))))))))) | |
85 | ||
86 | (define (error who format-string why what) | |
87 | (start-stack 'syncase-stack | |
88 | (scm-error 'misc-error | |
89 | who | |
8641dd9e | 90 | "~A ~S" |
a63812a2 JB |
91 | (list why what) |
92 | '()))) | |
93 | ||
94 | (define the-syncase-module (current-module)) | |
95 | ||
96 | (define (putprop symbol key binding) | |
97 | (let* ((m (current-module)) | |
98 | (v (or (module-variable m symbol) | |
99 | (module-make-local-var! m symbol)))) | |
a5b265e3 | 100 | (if (symbol-property symbol 'primitive-syntax) |
a63812a2 JB |
101 | (if (eq? (current-module) the-syncase-module) |
102 | (set-object-property! (module-variable the-root-module symbol) | |
103 | key | |
104 | binding)) | |
105 | (variable-set! v sc-macro)) | |
106 | (set-object-property! v key binding))) | |
107 | ||
108 | (define (getprop symbol key) | |
109 | (let* ((m (current-module)) | |
110 | (v (module-variable m symbol))) | |
111 | (and v (or (object-property v key) | |
112 | (let ((root-v (module-local-variable the-root-module symbol))) | |
113 | (and (equal? root-v v) | |
114 | (object-property root-v key))))))) | |
115 | ||
116 | (define generated-symbols (make-weak-key-hash-table 1019)) | |
117 | ||
a63812a2 JB |
118 | ;;; Utilities |
119 | ||
120 | (define (psyncomp) | |
121 | (system "mv -f psyntax.pp psyntax.pp~") | |
122 | (let ((in (open-input-file "psyntax.ss")) | |
123 | (out (open-output-file "psyntax.pp"))) | |
124 | (let loop ((x (read in))) | |
125 | (if (eof-object? x) | |
126 | (begin | |
127 | (close-port out) | |
128 | (close-port in)) | |
129 | (begin | |
130 | (write (sc-expand3 x 'c '(compile load eval)) out) | |
131 | (newline out) | |
132 | (loop (read in))))))) | |
133 | ||
134 | ;;; Load the preprocessed code | |
135 | ||
136 | (let ((old-debug #f) | |
137 | (old-read #f)) | |
138 | (dynamic-wind (lambda () | |
139 | (set! old-debug (debug-options)) | |
140 | (set! old-read (read-options))) | |
141 | (lambda () | |
142 | (debug-disable 'debug 'procnames) | |
143 | (read-disable 'positions) | |
144 | (load-from-path "ice-9/psyntax.pp")) | |
145 | (lambda () | |
146 | (debug-options old-debug) | |
147 | (read-options old-read)))) | |
148 | ||
149 | ||
4be092bc MD |
150 | ;;; The following lines are necessary only if we start making changes |
151 | ;; (use-syntax sc-expand) | |
a63812a2 JB |
152 | ;; (load-from-path "ice-9/psyntax.ss") |
153 | ||
154 | (define internal-eval (nested-ref the-scm-module '(app modules guile eval))) | |
155 | ||
6232c3dd | 156 | (define-public (eval x environment) |
a63812a2 | 157 | (internal-eval (if (and (pair? x) |
f304437e | 158 | (equal? (car x) "noexpand")) |
a63812a2 | 159 | (cadr x) |
6232c3dd MD |
160 | (sc-expand x)) |
161 | environment)) | |
a63812a2 JB |
162 | |
163 | ;;; Hack to make syncase macros work in the slib module | |
164 | (let ((m (nested-ref the-root-module '(app modules ice-9 slib)))) | |
165 | (if m | |
166 | (set-object-property! (module-local-variable m 'define) | |
167 | '*sc-expander* | |
168 | '(define)))) | |
169 | ||
170 | (define-public syncase sc-expand) |