1;;;; Copyright (C) 2000-2001,2004,2006,2008-2010,2019
2;;;;   Free Software Foundation, Inc.
3;;;;
4;;;; This library is free software; you can redistribute it and/or
5;;;; modify it under the terms of the GNU Lesser General Public
6;;;; License as published by the Free Software Foundation; either
7;;;; version 3 of the License, or (at your option) any later version.
8;;;;
9;;;; This library is distributed in the hope that it will be useful,
10;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12;;;; Lesser General Public License for more details.
13;;;;
14;;;; You should have received a copy of the GNU Lesser General Public
15;;;; License along with this library; if not, write to the Free Software
16;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17;;;;
18
19;;;; Safe subset of R5RS bindings
20
21(define-module (ice-9 safe-r5rs)
22  #:pure
23  #:use-module ((guile) #:hide (case cond syntax-rules _ => else ...))
24  #:use-module (ice-9 ports)
25  #:use-module ((guile) #:select ((_ . ^_)
26                                  (... . ^...)))
27  #:re-export (quote
28               quasiquote
29               unquote unquote-splicing
30               define-syntax let-syntax letrec-syntax
31               define lambda let let* letrec begin do
32               if set! delay and or
33
34               eqv? eq? equal?
35               number? complex? real? rational? integer?
36               exact? inexact?
37               = < > <= >=
38               zero? positive? negative? odd? even?
39               max min
40               + * - /
41               abs
42               quotient remainder modulo
43               gcd lcm
44               numerator denominator
45               rationalize
46               floor ceiling truncate round
47               exp log sin cos tan asin acos atan
48               sqrt
49               expt
50               make-rectangular make-polar real-part imag-part magnitude angle
51               exact->inexact inexact->exact
52
53               number->string string->number
54
55               boolean?
56               not
57
58               pair?
59               cons car cdr
60               set-car! set-cdr!
61               caar cadr cdar cddr
62               caaar caadr cadar caddr cdaar cdadr cddar cdddr
63               caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
64               cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
65               null?
66               list?
67               list
68               length
69               append
70               reverse
71               list-tail list-ref
72               memq memv member
73               assq assv assoc
74
75               symbol?
76               symbol->string string->symbol
77
78               char?
79               char=? char<? char>? char<=? char>=?
80               char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
81               char-alphabetic? char-numeric? char-whitespace?
82               char-upper-case? char-lower-case?
83               char->integer integer->char
84               char-upcase
85               char-downcase
86
87               string?
88               make-string
89               string
90               string-length
91               string-ref string-set!
92               string=? string-ci=?
93               string<? string>? string<=? string>=?
94               string-ci<? string-ci>? string-ci<=? string-ci>=?
95               substring
96               string-length
97               string-append
98               string->list list->string
99               string-copy string-fill!
100
101               vector?
102               make-vector
103               vector
104               vector-length
105               vector-ref vector-set!
106               vector->list list->vector
107               vector-fill!
108
109               procedure?
110               apply
111               map
112               for-each
113               force
114
115               call-with-current-continuation
116
117               values
118               call-with-values
119               dynamic-wind
120
121               eval
122
123               input-port? output-port?
124               current-input-port current-output-port
125
126               read
127               read-char
128               peek-char
129               eof-object?
130               char-ready?
131
132               write
133               display
134               newline
135               write-char
136
137               ;;transcript-on
138               ;;transcript-off
139               )
140
141  #:export (null-environment
142            syntax-rules cond case))
143
144;;; These definitions of `cond', `case', and `syntax-rules' differ from
145;;; the ones in Guile in that they expect their auxiliary syntax (`_',
146;;; `...', `else', and `=>') to be unbound.  They also don't support
147;;; some extensions from Guile (e.g. `=>' in `case'.).
148
149(define-syntax syntax-rules
150  (lambda (x)
151    (define (replace-underscores pattern)
152      (syntax-case pattern (_)
153        (_ #'^_)
154        ((x . y)
155         (with-syntax ((x (replace-underscores #'x))
156                       (y (replace-underscores #'y)))
157           #'(x . y)))
158        ((x . y)
159         (with-syntax ((x (replace-underscores #'x))
160                       (y (replace-underscores #'y)))
161           #'(x . y)))
162        (#(x ^...)
163         (with-syntax (((x ^...) (map replace-underscores #'(x ^...))))
164           #'#(x ^...)))
165        (x #'x)))
166    (syntax-case x ()
167      ((^_ dots (k ^...) . clauses)
168       (identifier? #'dots)
169       #'(with-ellipsis dots (syntax-rules (k ^...) . clauses)))
170      ((^_ (k ^...) ((keyword . pattern) template) ^...)
171       (with-syntax (((pattern ^...) (replace-underscores #'(pattern ^...))))
172         #`(lambda (x)
173             (syntax-case x (k ^...)
174               ((dummy . pattern) #'template)
175               ^...)))))))
176
177(define-syntax case
178  (lambda (stx)
179    (let lp ((stx stx))
180      (syntax-case stx (else)
181        (("case" x)
182         #'(if #f #f))
183        (("case" x ((y ^...) expr ^...) clause ^...)
184         #`(if (memv x '(y ^...))
185               (begin expr ^...)
186               #,(lp #'("case" x clause ^...))))
187        (("case" x (else expr ^...))
188         #'(begin expr ^...))
189        (("case" x clause . ^_)
190         (syntax-violation 'case "bad 'case' clause" #'clause))
191        ((^_ x clause clause* ^...)
192         #`(let ((t x))
193             #,(lp #'("case" t clause clause* ^...))))))))
194
195(define-syntax cond
196  (lambda (stx)
197    (let lp ((stx stx))
198      (syntax-case stx (else =>)
199        (("cond")
200         #'(if #f #f))
201        (("cond" (else expr ^...))
202         #'(begin expr ^...))
203        (("cond" (test => expr) clause ^...)
204         #`(let ((t test))
205             (if t
206                 (expr t)
207                 #,(lp #'("cond" clause ^...)))))
208        (("cond" (test) clause ^...)
209         #`(or test #,(lp #'("cond" clause ^...))))
210        (("cond" (test expr ^...) clause ^...)
211         #`(if test
212               (begin expr ^...)
213               #,(lp #'("cond" clause ^...))))
214        (("cond" clause . ^_)
215         (syntax-violation 'cond "bad 'cond' clause" #'clause))
216        ((^_ clause clause* ^...)
217         (lp #'("cond" clause clause* ^...)))))))
218
219(define (null-environment n)
220  (unless (eqv? n 5)
221    (scm-error 'misc-error 'null-environment
222               "~A is not a valid version" (list n) '()))
223  ;; Note that we need to create a *fresh* interface
224  (let ((interface (make-module)))
225    (set-module-kind! interface 'interface)
226    (define bindings
227      '(define quote lambda if set! cond case and or let let* letrec
228	 begin do delay quasiquote unquote
229         define-syntax let-syntax letrec-syntax syntax-rules))
230    (module-use! interface
231                 (resolve-interface '(ice-9 safe-r5rs) #:select bindings))
232    interface))
233