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