Commit | Line | Data |
---|---|---|
296ad2b4 KN |
1 | ;;;; Copyright (C) 1997, 2000 Free Software Foundation, Inc. |
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 | |
15 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
16 | ;;;; Boston, MA 02111-1307 USA | |
17 | ;;;; | |
18 | \f | |
19 | ||
20 | (define-module (language r5rs expand) | |
fdcedea6 | 21 | :export (expand void |
296ad2b4 KN |
22 | identifier? free-identifier=? bound-identifier=? |
23 | generate-temporaries datum->syntax-object syntax-object->datum)) | |
24 | ||
25 | (define sc-expand #f) | |
26 | (define $sc-put-cte #f) | |
27 | (define $syntax-dispatch #f) | |
28 | (define syntax-rules #f) | |
29 | (define syntax-error #f) | |
30 | (define identifier? #f) | |
31 | (define free-identifier=? #f) | |
32 | (define bound-identifier=? #f) | |
33 | (define generate-temporaries #f) | |
34 | (define datum->syntax-object #f) | |
35 | (define syntax-object->datum #f) | |
36 | ||
37 | (define void (lambda () (if #f #f))) | |
38 | ||
39 | (define andmap | |
40 | (lambda (f first . rest) | |
41 | (or (null? first) | |
42 | (if (null? rest) | |
43 | (let andmap ((first first)) | |
44 | (let ((x (car first)) (first (cdr first))) | |
45 | (if (null? first) | |
46 | (f x) | |
47 | (and (f x) (andmap first))))) | |
48 | (let andmap ((first first) (rest rest)) | |
49 | (let ((x (car first)) | |
50 | (xr (map car rest)) | |
51 | (first (cdr first)) | |
52 | (rest (map cdr rest))) | |
53 | (if (null? first) | |
54 | (apply f (cons x xr)) | |
55 | (and (apply f (cons x xr)) (andmap first rest))))))))) | |
56 | ||
57 | (define ormap | |
58 | (lambda (proc list1) | |
59 | (and (not (null? list1)) | |
60 | (or (proc (car list1)) (ormap proc (cdr list1)))))) | |
61 | ||
62 | (define putprop set-symbol-property!) | |
63 | (define getprop symbol-property) | |
64 | (define remprop symbol-property-remove!) | |
65 | ||
66 | (define syncase-module (current-module)) | |
67 | (define (sc-eval x) (eval x syncase-module)) | |
68 | ||
69 | (load "psyntax.scm") | |
70 | ||
71 | (define expand sc-expand) | |
72 | ||
73 | (define (rebuild) | |
74 | (call-with-input-file "psyntax.ss" | |
75 | (lambda (in) | |
76 | (call-with-output-file "psyntax.scm" | |
77 | (lambda (out) | |
78 | (do ((obj (read in) (read in))) | |
79 | ((eof-object? obj)) | |
80 | (write (sc-expand obj 'c '(eval load compile)) out))))))) | |
81 | ||
82 | ;(rebuild) |