Commit | Line | Data |
---|---|---|
ea9c5dab KN |
1 | ;;; R5RS syntax expander |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
5 | ;; 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 | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ;; | |
10 | ;; This program is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 | ;; GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
296ad2b4 KN |
21 | |
22 | (define-module (language r5rs expand) | |
fdcedea6 | 23 | :export (expand void |
296ad2b4 KN |
24 | identifier? free-identifier=? bound-identifier=? |
25 | generate-temporaries datum->syntax-object syntax-object->datum)) | |
26 | ||
27 | (define sc-expand #f) | |
28 | (define $sc-put-cte #f) | |
29 | (define $syntax-dispatch #f) | |
30 | (define syntax-rules #f) | |
31 | (define syntax-error #f) | |
32 | (define identifier? #f) | |
33 | (define free-identifier=? #f) | |
34 | (define bound-identifier=? #f) | |
35 | (define generate-temporaries #f) | |
36 | (define datum->syntax-object #f) | |
37 | (define syntax-object->datum #f) | |
38 | ||
39 | (define void (lambda () (if #f #f))) | |
40 | ||
41 | (define andmap | |
42 | (lambda (f first . rest) | |
43 | (or (null? first) | |
44 | (if (null? rest) | |
45 | (let andmap ((first first)) | |
46 | (let ((x (car first)) (first (cdr first))) | |
47 | (if (null? first) | |
48 | (f x) | |
49 | (and (f x) (andmap first))))) | |
50 | (let andmap ((first first) (rest rest)) | |
51 | (let ((x (car first)) | |
52 | (xr (map car rest)) | |
53 | (first (cdr first)) | |
54 | (rest (map cdr rest))) | |
55 | (if (null? first) | |
56 | (apply f (cons x xr)) | |
57 | (and (apply f (cons x xr)) (andmap first rest))))))))) | |
58 | ||
59 | (define ormap | |
60 | (lambda (proc list1) | |
61 | (and (not (null? list1)) | |
62 | (or (proc (car list1)) (ormap proc (cdr list1)))))) | |
63 | ||
64 | (define putprop set-symbol-property!) | |
65 | (define getprop symbol-property) | |
66 | (define remprop symbol-property-remove!) | |
67 | ||
68 | (define syncase-module (current-module)) | |
c4c8c433 KN |
69 | (define guile-eval eval) |
70 | (define (eval x) | |
71 | (if (and (pair? x) (equal? (car x) "noexpand")) | |
72 | (cdr x) | |
73 | (guile-eval x syncase-module))) | |
a80be762 | 74 | |
c4c8c433 KN |
75 | (define guile-error error) |
76 | (define (error who format-string why what) | |
77 | (guile-error why what)) | |
296ad2b4 | 78 | |
c4c8c433 | 79 | (load "psyntax.pp") |
296ad2b4 KN |
80 | |
81 | (define expand sc-expand) |