Gecko [ tsuru-no-tsurugi.tokyo ]

Name	Size	Permission	Date
peg	[ DIR ]	drwxr-xr-x	2025-03-06 19:41
and-let-star.scm	2.53 KB	-rw-r--r--	2021-05-10 17:28
arrays.scm	2.63 KB	-rw-r--r--	2021-05-10 17:28
atomic.scm	1.55 KB	-rw-r--r--	2021-05-10 17:28
binary-ports.scm	2.71 KB	-rw-r--r--	2021-05-10 17:28
boot-9.scm	166.42 KB	-rw-r--r--	2021-05-10 17:28
buffered-input.scm	4.82 KB	-rw-r--r--	2021-05-10 17:28
calling.scm	10.54 KB	-rw-r--r--	2021-05-10 17:28
command-line.scm	18.6 KB	-rw-r--r--	2021-05-10 17:28
common-list.scm	8.95 KB	-rw-r--r--	2021-05-10 17:28
control.scm	4.08 KB	-rw-r--r--	2021-05-10 17:28
copy-tree.scm	3.05 KB	-rw-r--r--	2021-05-10 17:28
curried-definitions.scm	1.79 KB	-rw-r--r--	2021-05-10 17:28
deprecated.scm	1.54 KB	-rw-r--r--	2021-05-10 17:28
documentation.scm	7.41 KB	-rw-r--r--	2021-08-27 06:21
eval-string.scm	2.99 KB	-rw-r--r--	2021-05-10 17:28
eval.scm	25.08 KB	-rw-r--r--	2021-05-10 17:28
exceptions.scm	14.38 KB	-rw-r--r--	2021-05-10 17:28
expect.scm	5.5 KB	-rw-r--r--	2021-05-10 17:28
fdes-finalizers.scm	1.06 KB	-rw-r--r--	2021-05-10 17:28
format.scm	65.47 KB	-rw-r--r--	2021-05-10 17:28
ftw.scm	25.06 KB	-rw-r--r--	2021-05-10 17:28
futures.scm	10.49 KB	-rw-r--r--	2021-05-10 17:28
gap-buffer.scm	9.59 KB	-rw-r--r--	2021-05-10 17:28
getopt-long.scm	16.49 KB	-rw-r--r--	2021-05-10 17:28
hash-table.scm	1.77 KB	-rw-r--r--	2021-05-10 17:28
hcons.scm	2.55 KB	-rw-r--r--	2021-05-10 17:28
history.scm	2.29 KB	-rw-r--r--	2021-05-10 17:28
i18n.scm	20.51 KB	-rw-r--r--	2021-05-10 17:28
iconv.scm	3.19 KB	-rw-r--r--	2021-05-10 17:28
lineio.scm	3.85 KB	-rw-r--r--	2021-05-10 17:28
list.scm	1.29 KB	-rw-r--r--	2021-05-10 17:28
local-eval.scm	9.84 KB	-rw-r--r--	2021-05-10 17:28
ls.scm	3.2 KB	-rw-r--r--	2021-05-10 17:28
match.scm	2.18 KB	-rw-r--r--	2021-05-10 17:28
match.upstream.scm	35.93 KB	-rw-r--r--	2021-05-10 17:28
networking.scm	3.33 KB	-rw-r--r--	2021-05-10 17:28
null.scm	1.21 KB	-rw-r--r--	2021-05-10 17:28
occam-channel.scm	7.26 KB	-rw-r--r--	2021-05-10 17:28
optargs.scm	15.75 KB	-rw-r--r--	2021-05-10 17:28
peg.scm	1.64 KB	-rw-r--r--	2021-05-10 17:28
poe.scm	3.3 KB	-rw-r--r--	2021-05-10 17:28
poll.scm	5.79 KB	-rw-r--r--	2021-05-10 17:28
popen.scm	9.27 KB	-rw-r--r--	2021-05-10 17:28
ports.scm	19.08 KB	-rw-r--r--	2021-05-10 17:28
posix.scm	2.73 KB	-rw-r--r--	2021-05-10 17:28
pretty-print.scm	16.88 KB	-rw-r--r--	2021-05-10 17:28
psyntax-pp.scm	182.88 KB	-rw-r--r--	2021-05-10 17:28
psyntax.scm	148.97 KB	-rw-r--r--	2021-08-27 06:21
q.scm	4.2 KB	-rw-r--r--	2021-05-10 17:28
quasisyntax.scm	5.22 KB	-rw-r--r--	2021-05-10 17:28
r5rs.scm	1.56 KB	-rw-r--r--	2021-05-10 17:28
r6rs-libraries.scm	10.38 KB	-rw-r--r--	2021-05-10 17:28
r7rs-libraries.scm	4.28 KB	-rw-r--r--	2021-05-10 17:28
rdelim.scm	7.72 KB	-rw-r--r--	2021-05-10 17:28
read.scm	32.52 KB	-rw-r--r--	2021-05-10 17:28
readline.scm	9.56 KB	-rw-r--r--	2021-05-10 17:28
receive.scm	1.06 KB	-rw-r--r--	2021-05-10 17:28
regex.scm	8.87 KB	-rw-r--r--	2021-05-10 17:28
runq.scm	8.18 KB	-rw-r--r--	2021-05-10 17:28
rw.scm	1.02 KB	-rw-r--r--	2021-05-10 17:28
safe-r5rs.scm	7.5 KB	-rw-r--r--	2021-05-10 17:28
safe.scm	1.25 KB	-rw-r--r--	2021-05-10 17:28
sandbox.scm	34.24 KB	-rw-r--r--	2021-05-10 17:28
save-stack.scm	2.15 KB	-rw-r--r--	2021-05-10 17:28
scm-style-repl.scm	11.62 KB	-rw-r--r--	2021-05-10 17:28
serialize.scm	3.78 KB	-rw-r--r--	2021-05-10 17:28
session.scm	17.72 KB	-rw-r--r--	2021-05-10 17:28
slib.scm	1.55 KB	-rw-r--r--	2021-05-10 17:28
stack-catch.scm	1.94 KB	-rw-r--r--	2021-05-10 17:28
streams.scm	5.86 KB	-rw-r--r--	2021-05-10 17:28
string-fun.scm	9.68 KB	-rw-r--r--	2021-05-10 17:28
suspendable-ports.scm	29.86 KB	-rw-r--r--	2021-05-10 17:28
textual-ports.scm	2.29 KB	-rw-r--r--	2021-05-10 17:28
threads.scm	12.54 KB	-rw-r--r--	2021-05-10 17:28
time.scm	2.07 KB	-rw-r--r--	2021-05-10 17:28
top-repl.scm	2.63 KB	-rw-r--r--	2021-05-10 17:28
unicode.scm	1005 B	-rw-r--r--	2021-05-10 17:28
vlist.scm	21.56 KB	-rw-r--r--	2021-05-10 17:28
weak-vector.scm	1.2 KB	-rw-r--r--	2021-05-10 17:28

Rename

;;;; 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>=?
               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

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!

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))