mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
(ice-9 safe-r5rs) fixes for bound aux syntax
* module/ice-9/safe-r5rs.scm: Define local versions of `case' and `cond' that assume aux syntax is unbound. If this doesn't work, we can switch to exporting aux syntax. * module/ice-9/top-repl.scm (top-repl): Don't add (ice-9 r5rs) to the REPL environment.
This commit is contained in:
Andy Wingo
parent
2e335635cc
commit
3e02bf7259
2 changed files with 209 additions and 124 deletions
|
|
@ -1,4 +1,5 @@
|
|||
;;;; Copyright (C) 2000, 2001, 2004, 2006, 2010 Free Software Foundation, Inc.
|
||||
;;;; 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
|
||||
|
|
@ -18,128 +19,214 @@
|
|||
;;;; Safe subset of R5RS bindings
|
||||
|
||||
(define-module (ice-9 safe-r5rs)
|
||||
:re-export (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
|
||||
#: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
|
||||
|
||||
number->string string->number
|
||||
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
|
||||
|
||||
boolean?
|
||||
not
|
||||
number->string string->number
|
||||
|
||||
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
|
||||
boolean?
|
||||
not
|
||||
|
||||
symbol?
|
||||
symbol->string string->symbol
|
||||
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
|
||||
|
||||
char?
|
||||
char=? char<? char>? char<=? char>=?
|
||||
char-ci=? 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
|
||||
symbol?
|
||||
symbol->string string->symbol
|
||||
|
||||
string?
|
||||
make-string
|
||||
string
|
||||
string-length
|
||||
string-ref string-set!
|
||||
string=? string-ci=?
|
||||
string<? string>? string<=? string>=?
|
||||
string-ci<? string-ci>? string-ci<=? string-ci>=?
|
||||
substring
|
||||
string-length
|
||||
string-append
|
||||
string->list list->string
|
||||
string-copy string-fill!
|
||||
char?
|
||||
char=? char<? char>? char<=? char>=?
|
||||
char-ci=? 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
|
||||
|
||||
vector?
|
||||
make-vector
|
||||
vector
|
||||
vector-length
|
||||
vector-ref vector-set!
|
||||
vector->list list->vector
|
||||
vector-fill!
|
||||
string?
|
||||
make-string
|
||||
string
|
||||
string-length
|
||||
string-ref string-set!
|
||||
string=? string-ci=?
|
||||
string<? string>? string<=? string>=?
|
||||
string-ci<? string-ci>? string-ci<=? string-ci>=?
|
||||
substring
|
||||
string-length
|
||||
string-append
|
||||
string->list list->string
|
||||
string-copy string-fill!
|
||||
|
||||
procedure?
|
||||
apply
|
||||
map
|
||||
for-each
|
||||
force
|
||||
vector?
|
||||
make-vector
|
||||
vector
|
||||
vector-length
|
||||
vector-ref vector-set!
|
||||
vector->list list->vector
|
||||
vector-fill!
|
||||
|
||||
call-with-current-continuation
|
||||
procedure?
|
||||
apply
|
||||
map
|
||||
for-each
|
||||
force
|
||||
|
||||
values
|
||||
call-with-values
|
||||
dynamic-wind
|
||||
call-with-current-continuation
|
||||
|
||||
eval
|
||||
values
|
||||
call-with-values
|
||||
dynamic-wind
|
||||
|
||||
input-port? output-port?
|
||||
current-input-port current-output-port
|
||||
eval
|
||||
|
||||
read
|
||||
read-char
|
||||
peek-char
|
||||
eof-object?
|
||||
char-ready?
|
||||
input-port? output-port?
|
||||
current-input-port current-output-port
|
||||
|
||||
write
|
||||
display
|
||||
newline
|
||||
write-char
|
||||
read
|
||||
read-char
|
||||
peek-char
|
||||
eof-object?
|
||||
char-ready?
|
||||
|
||||
;;transcript-on
|
||||
;;transcript-off
|
||||
)
|
||||
write
|
||||
display
|
||||
newline
|
||||
write-char
|
||||
|
||||
:export (null-environment))
|
||||
;;transcript-on
|
||||
;;transcript-off
|
||||
)
|
||||
|
||||
(define null-interface (resolve-interface '(ice-9 null)))
|
||||
#:export (null-environment
|
||||
syntax-rules cond case))
|
||||
|
||||
(module-use! (module-public-interface (current-module))
|
||||
null-interface)
|
||||
;;; 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)
|
||||
(if (not (= n 5))
|
||||
(scm-error 'misc-error 'null-environment
|
||||
"~A is not a valid version"
|
||||
(list 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 31)))
|
||||
(let ((interface (make-module)))
|
||||
(set-module-kind! interface 'interface)
|
||||
(module-use! interface null-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))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
;;; -*- mode: scheme; coding: utf-8; -*-
|
||||
|
||||
;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
|
||||
;;;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 1995-2011,2013,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
|
||||
|
|
@ -53,8 +52,7 @@
|
|||
(set-current-module guile-user-module)
|
||||
(process-use-modules
|
||||
(append
|
||||
'(((ice-9 r5rs))
|
||||
((ice-9 session)))
|
||||
'(((ice-9 session)))
|
||||
(if (provided? 'regex)
|
||||
'(((ice-9 regex)))
|
||||
'())
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue