;;;; Copyright (C) 2000-2001,2004,2006,2008-2010,2019 ;;;; Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; ;;;; Safe subset of R5RS bindings (define-module (ice-9 safe-r5rs) #:pure #:use-module ((guile) #:hide (case cond syntax-rules _ => else ...)) #:use-module (ice-9 ports) #:use-module ((guile) #:select ((_ . ^_) (... . ^...))) #:re-export (quote quasiquote unquote unquote-splicing define-syntax let-syntax letrec-syntax define lambda let let* letrec begin do if set! delay and or eqv? eq? equal? number? complex? real? rational? integer? exact? inexact? = < > <= >= zero? positive? negative? odd? even? max min + * - / abs quotient remainder modulo gcd lcm numerator denominator rationalize floor ceiling truncate round exp log sin cos tan asin acos atan sqrt expt make-rectangular make-polar real-part imag-part magnitude angle exact->inexact inexact->exact number->string string->number boolean? not pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr null? list? list length append reverse list-tail list-ref memq memv member assq assv assoc symbol? symbol->string string->symbol char? char=? char? char<=? char>=? char-ci=? char-ci? char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace? char-upper-case? char-lower-case? char->integer integer->char char-upcase char-downcase string? make-string string string-length string-ref string-set! string=? string-ci=? string? string<=? string>=? string-ci? string-ci<=? string-ci>=? substring string-length string-append string->list list->string string-copy string-fill! vector? make-vector vector vector-length vector-ref vector-set! vector->list list->vector vector-fill! procedure? apply map for-each force call-with-current-continuation values call-with-values dynamic-wind eval input-port? output-port? current-input-port current-output-port read read-char peek-char eof-object? char-ready? write display newline write-char ;;transcript-on ;;transcript-off ) #:export (null-environment syntax-rules cond case)) ;;; These definitions of `cond', `case', and `syntax-rules' differ from ;;; the ones in Guile in that they expect their auxiliary syntax (`_', ;;; `...', `else', and `=>') to be unbound. They also don't support ;;; some extensions from Guile (e.g. `=>' in `case'.). (define-syntax syntax-rules (lambda (x) (define (replace-underscores pattern) (syntax-case pattern (_) (_ #'^_) ((x . y) (with-syntax ((x (replace-underscores #'x)) (y (replace-underscores #'y))) #'(x . y))) ((x . y) (with-syntax ((x (replace-underscores #'x)) (y (replace-underscores #'y))) #'(x . y))) (#(x ^...) (with-syntax (((x ^...) (map replace-underscores #'(x ^...)))) #'#(x ^...))) (x #'x))) (syntax-case x () ((^_ dots (k ^...) . clauses) (identifier? #'dots) #'(with-ellipsis dots (syntax-rules (k ^...) . clauses))) ((^_ (k ^...) ((keyword . pattern) template) ^...) (with-syntax (((pattern ^...) (replace-underscores #'(pattern ^...)))) #`(lambda (x) (syntax-case x (k ^...) ((dummy . pattern) #'template) ^...))))))) (define-syntax case (lambda (stx) (let lp ((stx stx)) (syntax-case stx (else) (("case" x) #'(if #f #f)) (("case" x ((y ^...) expr ^...) clause ^...) #`(if (memv x '(y ^...)) (begin expr ^...) #,(lp #'("case" x clause ^...)))) (("case" x (else expr ^...)) #'(begin expr ^...)) (("case" x clause . ^_) (syntax-violation 'case "bad 'case' clause" #'clause)) ((^_ x clause clause* ^...) #`(let ((t x)) #,(lp #'("case" t clause clause* ^...)))))))) (define-syntax cond (lambda (stx) (let lp ((stx stx)) (syntax-case stx (else =>) (("cond") #'(if #f #f)) (("cond" (else expr ^...)) #'(begin expr ^...)) (("cond" (test => expr) clause ^...) #`(let ((t test)) (if t (expr t) #,(lp #'("cond" clause ^...))))) (("cond" (test) clause ^...) #`(or test #,(lp #'("cond" clause ^...)))) (("cond" (test expr ^...) clause ^...) #`(if test (begin expr ^...) #,(lp #'("cond" clause ^...)))) (("cond" clause . ^_) (syntax-violation 'cond "bad 'cond' clause" #'clause)) ((^_ clause clause* ^...) (lp #'("cond" clause clause* ^...))))))) (define (null-environment n) (unless (eqv? n 5) (scm-error 'misc-error 'null-environment "~A is not a valid version" (list n) '())) ;; Note that we need to create a *fresh* interface (let ((interface (make-module))) (set-module-kind! interface 'interface) (define bindings '(define quote lambda if set! cond case and or let let* letrec begin do delay quasiquote unquote define-syntax let-syntax letrec-syntax syntax-rules)) (module-use! interface (resolve-interface '(ice-9 safe-r5rs) #:select bindings)) interface))