486 lines
16 KiB
Scheme
486 lines
16 KiB
Scheme
|
|
(module main scheme/base
|
|
(require (for-syntax scheme/base))
|
|
|
|
(provide (for-syntax syntax-rules ...)
|
|
(rename-out
|
|
[mcons cons]
|
|
[mcar car]
|
|
[mcdr cdr]
|
|
[set-mcar! set-car!]
|
|
[set-mcdr! set-cdr!]
|
|
[mpair? pair?]
|
|
[mmap map]
|
|
[mfor-each for-each])
|
|
= < > <= >= max min + - * /
|
|
abs gcd lcm exp log sin cos tan not eq?
|
|
call-with-current-continuation make-string
|
|
symbol->string string->symbol make-rectangular
|
|
exact->inexact inexact->exact number->string string->number
|
|
rationalize output-port? current-input-port current-output-port current-error-port
|
|
open-input-file open-output-file close-input-port close-output-port
|
|
with-output-to-file transcript-on transcript-off flush-output
|
|
string-length string-ci<=? string-ci>=? string-append
|
|
string-fill!
|
|
(rename-out [string->mlist string->list]
|
|
[mlist->string list->string])
|
|
vector-length vector-fill!
|
|
(rename-out [vector->mlist vector->list]
|
|
[mlist->vector list->vector])
|
|
char-alphabetic? char-numeric? char-whitespace?
|
|
char-upper-case? char-lower-case? char->integer integer->char char-downcase
|
|
call-with-output-file call-with-input-file with-input-from-file
|
|
(rename-out [mapply apply]) symbol?
|
|
null?
|
|
(rename-out [mlist? list?]
|
|
[mlist list]
|
|
[mlength length]
|
|
[mappend append]
|
|
[mreverse reverse]
|
|
[mlist-tail list-tail]
|
|
[mlist-ref list-ref]
|
|
[mmemq memq]
|
|
[mmemv memv]
|
|
[mmember member]
|
|
[massq assq]
|
|
[massv assv]
|
|
[massoc assoc])
|
|
procedure?
|
|
number? complex? real? rational? integer? exact? inexact? zero?
|
|
positive? negative? odd? even?
|
|
quotient remainder modulo floor ceiling truncate round
|
|
numerator denominator asin acos atan sqrt
|
|
expt make-polar real-part imag-part angle magnitude input-port?
|
|
(rename-out [mread read])
|
|
read-char peek-char eof-object?
|
|
char-ready?
|
|
(rename-out [mwrite write]
|
|
[mdisplay display])
|
|
newline write-char load
|
|
string? string string-ref string-set! string=? substring string-copy
|
|
string-ci=? string<? string>? string<=? string>=? string-ci<? string-ci>?
|
|
vector? make-vector vector vector-ref vector-set!
|
|
char? char=? char<? char>? char<=? char>=?
|
|
char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
|
|
char-upcase boolean? eqv? equal? force
|
|
call-with-values values dynamic-wind
|
|
(rename-out [meval eval])
|
|
scheme-report-environment null-environment interaction-environment)
|
|
|
|
;; Because mcar and mcdr are inlined by the JIT
|
|
(define-syntax provide-inlined-combo
|
|
(syntax-rules ()
|
|
[(_ id orig mc1r mc2r)
|
|
(begin
|
|
(define-syntax id
|
|
(syntax-id-rules (set!)
|
|
[(_ x) (mc1r (mc2r x))]
|
|
[(set! _ v) (set! orig v)]
|
|
[_ (lambda (x) (mc1r (mc2r x)))]))
|
|
(provide (rename-out [id orig])))]))
|
|
|
|
(provide-inlined-combo mcaar caar mcar mcar)
|
|
(provide-inlined-combo mcadr cadr mcar mcdr)
|
|
(provide-inlined-combo mcdar cdar mcdr mcar)
|
|
(provide-inlined-combo mcddr cddr mcdr mcdr)
|
|
|
|
(define-syntax (provide-combination stx)
|
|
(syntax-case stx ()
|
|
[(_ id)
|
|
(with-syntax ([body
|
|
(let loop ([ops (let ([s (symbol->string (syntax-e #'id))])
|
|
(string->list (substring s 1 (sub1 (string-length s)))))])
|
|
(if (null? ops)
|
|
'x
|
|
`(,(if (equal? (car ops) #\a) 'mcar 'mcdr)
|
|
,(loop (cdr ops)))))]
|
|
[mid (datum->syntax #'id
|
|
(string->symbol (format "m~a" (syntax-e #'id)))
|
|
#'id)])
|
|
#'(begin
|
|
(define mid (lambda (x) body))
|
|
(provide (rename-out [mid id]))))]
|
|
[(_ id ...) #'(begin (provide-combination id) ...)]))
|
|
|
|
(provide-combination caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
|
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
|
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)
|
|
|
|
(define mmap
|
|
(case-lambda
|
|
[(f l) (let loop ([l l])
|
|
(cond
|
|
[(null? l) null]
|
|
[else (mcons (f (mcar l)) (loop (mcdr l)))]))]
|
|
[(f l1 l2) (let loop ([l1 l1][l2 l2])
|
|
(cond
|
|
[(null? l1) null]
|
|
[else (mcons (f (mcar l1) (mcar l2))
|
|
(loop (mcdr l1) (mcdr l2)))]))]
|
|
[(f l . ls) (let loop ([l l][ls ls])
|
|
(cond
|
|
[(null? l) null]
|
|
[else (mcons (apply f (mcar l) (map mcar ls))
|
|
(loop (mcdr l) (map mcdr ls)))]))]))
|
|
|
|
(define mfor-each
|
|
(case-lambda
|
|
[(f l) (let loop ([l l])
|
|
(cond
|
|
[(null? l) (void)]
|
|
[else (f (mcar l))
|
|
(loop (mcdr l))]))]
|
|
[(f l1 l2) (let loop ([l1 l1][l2 l2])
|
|
(cond
|
|
[(null? l1) (void)]
|
|
[else (f (mcar l1) (mcar l2))
|
|
(loop (mcdr l1) (mcdr l2))]))]
|
|
[(f l . ls) (let loop ([l l][ls ls])
|
|
(cond
|
|
[(null? l) (void)]
|
|
[else (apply f (mcar l) (map mcar ls))
|
|
(loop (mcdr l) (map mcdr ls))]))]))
|
|
|
|
(define (list->mlist l)
|
|
(cond
|
|
[(null? l) null]
|
|
[else (mcons (car l) (list->mlist (cdr l)))]))
|
|
|
|
(define (mlist->list l)
|
|
(cond
|
|
[(null? l) null]
|
|
[else (cons (mcar l) (mlist->list (mcdr l)))]))
|
|
|
|
(define (string->mlist s) (list->mlist (string->list s)))
|
|
(define (mlist->string s) (list->string (mlist->list s)))
|
|
|
|
(define (vector->mlist s) (list->mlist (vector->list s)))
|
|
(define (mlist->vector s) (list->vector (mlist->list s)))
|
|
|
|
(define mapply
|
|
(case-lambda
|
|
[(f l) (apply f (mlist->list l))]
|
|
[(f l0 . l)
|
|
(apply f (let loop ([l (cons l0 l)])
|
|
(if (null? (cdr l))
|
|
(mlist->list (car l))
|
|
(cons (car l) (loop (cdr l))))))]))
|
|
|
|
(define mlist
|
|
(case-lambda
|
|
[() null]
|
|
[(a) (mcons a null)]
|
|
[(a b) (mcons a (mcons b null))]
|
|
[(a b c) (mcons a (mcons b (mcons c null)))]
|
|
[(a b c d) (mcons a (mcons b (mcons c (mcons d null))))]
|
|
[l (list->mlist l)]))
|
|
|
|
(define (mlist? l)
|
|
(cond
|
|
[(null? l) #t]
|
|
[(mpair? l) (mlist? (mcdr l))]
|
|
[else #f]))
|
|
|
|
(define (mlength l)
|
|
(let loop ([l l][len 0])
|
|
(cond
|
|
[(null? l) len]
|
|
[else (loop (mcdr l) (add1 len))])))
|
|
|
|
(define mappend
|
|
(case-lambda
|
|
[() null]
|
|
[(a) a]
|
|
[(a b) (let loop ([a a])
|
|
(if (null? a)
|
|
b
|
|
(mcons (mcar a) (loop (mcdr a)))))]
|
|
[(a . l) (mappend a (apply mappend l))]))
|
|
|
|
(define (mreverse l)
|
|
(let loop ([l l][a null])
|
|
(cond
|
|
[(null? l) a]
|
|
[else (loop (mcdr l) (mcons (mcar l) a))])))
|
|
|
|
(define (mlist-tail l n)
|
|
(cond
|
|
[(zero? n) l]
|
|
[else (mlist-tail (mcdr l) (sub1 n))]))
|
|
|
|
(define (mlist-ref l n)
|
|
(cond
|
|
[(zero? n) (mcar l)]
|
|
[else (mlist-ref (mcdr l) (sub1 n))]))
|
|
|
|
(define (do-member =? v l)
|
|
(let loop ([l l])
|
|
(cond
|
|
[(null? l) #f]
|
|
[(=? v (mcar l)) l]
|
|
[else (loop (mcdr l))])))
|
|
|
|
(define (mmemq v l)
|
|
(do-member eq? v l))
|
|
|
|
(define (mmemv v l)
|
|
(do-member eqv? v l))
|
|
|
|
(define (mmember v l)
|
|
(do-member equal? v l))
|
|
|
|
|
|
(define (do-assoc =? v l)
|
|
(let loop ([l l])
|
|
(cond
|
|
[(null? l) #f]
|
|
[(=? v (mcar (mcar l))) (mcar l)]
|
|
[else (loop (mcdr l))])))
|
|
|
|
(define (massq v l)
|
|
(do-assoc eq? v l))
|
|
|
|
(define (massv v l)
|
|
(do-assoc eqv? v l))
|
|
|
|
(define (massoc v l)
|
|
(do-assoc equal? v l))
|
|
|
|
;; --------------------------------------------------
|
|
|
|
(define mread
|
|
(case-lambda
|
|
[() (mread (current-input-port))]
|
|
[(port) (let loop ([v (read port)])
|
|
(cond
|
|
[(pair? v) (mcons (loop (car v)) (loop (cdr v)))]
|
|
[(vector? v) (list->vector
|
|
(map loop (vector->list v)))]
|
|
[else v]))]))
|
|
|
|
(define mwrite
|
|
(case-lambda
|
|
[(v) (mwrite v (current-output-port))]
|
|
[(v port) (parameterize ([print-mpair-curly-braces #f])
|
|
(write v port))]))
|
|
|
|
(define mdisplay
|
|
(case-lambda
|
|
[(v) (mdisplay v (current-output-port))]
|
|
[(v port) (parameterize ([print-mpair-curly-braces #f])
|
|
(display v port))]))
|
|
|
|
;; --------------------------------------------------
|
|
|
|
(define-syntax (r5rs:quote stx)
|
|
(syntax-case stx ()
|
|
[(_ form)
|
|
;; Look for quoted pairs:
|
|
(if (let loop ([form #'form])
|
|
(syntax-case form ()
|
|
[(a . b) #t]
|
|
[#(a ...)
|
|
(ormap loop (syntax->list #'(a ...)))]
|
|
[_ #f]))
|
|
;; quote has to create mpairs:
|
|
(syntax-local-lift-expression (let loop ([form #'form])
|
|
(syntax-case form ()
|
|
[(a . b)
|
|
#`(mcons #,(loop #'a) #,(loop #'b))]
|
|
[#(a ...)
|
|
#`(vector . #,(map loop (syntax->list #'(a ...))))]
|
|
[other #'(quote other)])))
|
|
;; no pairs to worry about:
|
|
#'(quote form))]))
|
|
|
|
(define-syntax (r5rs:quasiquote stx)
|
|
(syntax-case stx ()
|
|
[(_ form)
|
|
;; Look for unquote or unquote-splicing.
|
|
;; This should be improved to discount unquote[-splicing]
|
|
;; under a nested quasiquote.
|
|
(if (let loop ([form #'form])
|
|
(syntax-case form (unquote unquote-splicing)
|
|
[unquote #t]
|
|
[unquote-splicing #t]
|
|
[(a . b) (or (loop #'a) (loop #'b))]
|
|
[#(a ...)
|
|
(ormap loop (syntax->list #'(a ...)))]
|
|
[_ #f]))
|
|
;; Found an unquote[-splicing], so convert:
|
|
(let loop ([form #'form][depth 0])
|
|
(syntax-case form (unquote unquote-splicing r5rs:quasiquote)
|
|
[(unquote e)
|
|
(if (zero? depth)
|
|
#'e
|
|
#`(mcons 'unquote
|
|
(mcons
|
|
#,(loop #'e (sub1 depth))
|
|
null)))]
|
|
[unquote
|
|
(zero? depth)
|
|
(raise-syntax-error
|
|
"invalid content within quasiquote"
|
|
stx
|
|
form)]
|
|
[((unquote-splicing e) . rest)
|
|
(if (zero? depth)
|
|
#`(mappend e #,(loop #'rest depth))
|
|
#`(mcons (mcons 'unquote-splicing
|
|
(mcons #,(loop #'e (sub1 depth))
|
|
null))
|
|
#,(loop #'rest depth)))]
|
|
[unquote-splicing
|
|
(zero? depth)
|
|
(raise-syntax-error
|
|
"invalid content within quasiquote"
|
|
stx
|
|
form)]
|
|
[(r5rs:quasiquote . e)
|
|
#`(mcons 'quasiquote #,(loop #'e (add1 depth)))]
|
|
[(a . b)
|
|
#`(mcons #,(loop #'a depth) #,(loop #'b depth))]
|
|
[#(a ...)
|
|
#`(vector . #,(map (lambda (e) (loop e depth))
|
|
(syntax->list #'(a ...))))]
|
|
[other #'(r5rs:quote other)]))
|
|
;; None, so just use R5RS quote:
|
|
#'(r5rs:quote form))]))
|
|
|
|
;; Copied from R5rS, but with an added `let' around body,
|
|
;; and with optimization for precedure letrecs
|
|
(define undefined (letrec ([u u]) u))
|
|
(define-syntax r5rs:letrec
|
|
(syntax-rules (r5rs-lambda)
|
|
((r5rs:letrec ((var1 (r5rs-lambda . _rest)) ...) body ...)
|
|
(letrec ((var1 (r5rs-lambda . _rest)) ...) body ...))
|
|
((r5rs:letrec ((var1 init1) ...) body ...)
|
|
(r5rs:letrec "generate_temp_names"
|
|
(var1 ...)
|
|
()
|
|
((var1 init1) ...)
|
|
body ...))
|
|
((r5rs:letrec "generate_temp_names"
|
|
()
|
|
(temp1 ...)
|
|
((var1 init1) ...)
|
|
body ...)
|
|
(let ((var1 undefined) ...)
|
|
(let ((temp1 init1) ...)
|
|
(set! var1 temp1)
|
|
...
|
|
(let ()
|
|
body ...))))
|
|
((r5rs:letrec "generate_temp_names"
|
|
(x y ...)
|
|
(temp ...)
|
|
((var1 init1) ...)
|
|
body ...)
|
|
(r5rs:letrec "generate_temp_names"
|
|
(y ...)
|
|
(newtemp temp ...)
|
|
((var1 init1) ...)
|
|
body ...))))
|
|
|
|
(define-syntax r5rs:lambda
|
|
;; Convert rest-arg list to mlist:
|
|
(syntax-rules ()
|
|
[(_ (id ...) . body)
|
|
(#%plain-lambda (id ...) . body)]
|
|
[(_ (id ... . rest) . body)
|
|
(#%plain-lambda (id ... . rest)
|
|
(let ([rest (list->mlist rest)])
|
|
. body))]))
|
|
|
|
(define-syntax (r5rs:define stx)
|
|
;; Use r5rs:lambda
|
|
(syntax-case stx ()
|
|
[(_ (id . args) . body)
|
|
(with-syntax ([proc
|
|
(syntax/loc stx
|
|
(r5rs:lambda args . body))])
|
|
(syntax/loc stx
|
|
(define id proc)))]
|
|
[(_ . rest)
|
|
(syntax/loc stx
|
|
(define . rest))]))
|
|
|
|
(define-syntax (r5rs:define-syntax stx)
|
|
(syntax-case stx ()
|
|
[(_ id expr)
|
|
(identifier? #'id)
|
|
(syntax/loc stx
|
|
(define-syntax id expr))]))
|
|
|
|
(define-syntax r5rs:if
|
|
(syntax-rules ()
|
|
[(_ test then)
|
|
(if test then (void))]
|
|
[(_ test then else)
|
|
(if test then else)]))
|
|
|
|
(provide unquote unquote-splicing
|
|
(rename-out [r5rs:quote quote]
|
|
[r5rs:quasiquote quasiquote]
|
|
[r5rs:if if]
|
|
[r5rs:lambda lambda]
|
|
[r5rs:letrec letrec]
|
|
[r5rs:define define]
|
|
[r5rs:define-syntax define-syntax])
|
|
let and or cond case delay do
|
|
let* begin set!
|
|
let-syntax letrec-syntax
|
|
=> else
|
|
|
|
;; We have to include the following MzScheme-isms to do anything,
|
|
;; but they're not legal R5RS names, anyway.
|
|
(rename-out [#%plain-module-begin #%module-begin])
|
|
#%app #%datum #%top #%top-interaction
|
|
#%require #%provide)
|
|
|
|
;; --------------------------------------------------
|
|
|
|
(define-namespace-anchor here)
|
|
|
|
(define (scheme-report-environment n)
|
|
(unless (= n 5)
|
|
(raise-type-error 'scheme-report-environment "5" n))
|
|
(mk-r5rs #f))
|
|
|
|
(define (null-environment n)
|
|
(unless (= n 5)
|
|
(raise-type-error 'null-environment "5" n))
|
|
(mk-r5rs #t))
|
|
|
|
(define (mk-r5rs stx-only?)
|
|
(let ([n (namespace-anchor->empty-namespace here)])
|
|
(parameterize ([current-namespace n])
|
|
(if stx-only?
|
|
(namespace-require '(only r5rs
|
|
quote quasiquote
|
|
if lambda letrec
|
|
let and or cond case define delay do
|
|
let* begin set!
|
|
define-syntax let-syntax letrec-syntax
|
|
=> else
|
|
#%app #%datum #%top #%top-interaction
|
|
#%require #%provide))
|
|
(begin
|
|
(namespace-require 'r5rs) ; for syntax
|
|
(namespace-require/copy 'r5rs))))
|
|
n))
|
|
|
|
(define (interaction-environment)
|
|
(current-namespace))
|
|
|
|
(define (meval expr env)
|
|
(eval (let loop ([expr expr])
|
|
(cond
|
|
[(mpair? expr)
|
|
(cons (loop (mcar expr))
|
|
(loop (mcdr expr)))]
|
|
[(vector? expr)
|
|
(list->vector (map loop (vector->list expr)))]
|
|
[else expr]))
|
|
env)))
|