use #lang and reindent
svn: r15916
This commit is contained in:
Eli Barzilay
parent
49c447fe11
commit
70cf9b6d62
|
|
@ -1,205 +1,208 @@
|
|||
(module eopl mzscheme
|
||||
(require "datatype.ss"
|
||||
"private/sllgen.ss"
|
||||
mzlib/trace
|
||||
mzlib/pretty)
|
||||
(require-for-syntax "private/slldef.ss")
|
||||
#lang mzscheme
|
||||
|
||||
(provide define-datatype
|
||||
cases)
|
||||
(require "datatype.ss"
|
||||
"private/sllgen.ss"
|
||||
mzlib/trace
|
||||
mzlib/pretty)
|
||||
(require-for-syntax "private/slldef.ss")
|
||||
|
||||
;; Special def that saves a quoted value at compile time in case
|
||||
;; it's needed for `sllgen:make-define-datatypes':
|
||||
(define-syntax (eopl-define stx)
|
||||
(syntax-case stx (quote)
|
||||
[(_ name (quote def))
|
||||
(identifier? (syntax name))
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(begin-for-syntax (hash-table-put! sllgen-def 'name (quote-syntax def)))
|
||||
(define name (quote def))))]
|
||||
[(_ . rest)
|
||||
(syntax/loc stx (define . rest))]))
|
||||
(provide define-datatype
|
||||
cases)
|
||||
|
||||
(provide (rename eopl-define define))
|
||||
;; Special def that saves a quoted value at compile time in case
|
||||
;; it's needed for `sllgen:make-define-datatypes':
|
||||
(define-syntax (eopl-define stx)
|
||||
(syntax-case stx (quote)
|
||||
[(_ name (quote def))
|
||||
(identifier? (syntax name))
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(begin-for-syntax
|
||||
(hash-table-put! sllgen-def 'name (quote-syntax def)))
|
||||
(define name (quote def))))]
|
||||
[(_ . rest)
|
||||
(syntax/loc stx (define . rest))]))
|
||||
|
||||
(provide (all-from "private/sllgen.ss"))
|
||||
(provide (rename eopl-define define))
|
||||
|
||||
(provide (rename error eopl:error)
|
||||
(rename printf eopl:printf)
|
||||
(rename pretty-print eopl:pretty-print)
|
||||
(rename eopl:call-with-current-continuation call-with-current-continuation))
|
||||
(provide (all-from "private/sllgen.ss"))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(provide (rename error eopl:error)
|
||||
(rename printf eopl:printf)
|
||||
(rename pretty-print eopl:pretty-print)
|
||||
(rename eopl:call-with-current-continuation
|
||||
call-with-current-continuation))
|
||||
|
||||
;; Ugly:
|
||||
;;
|
||||
;; 1) `eopl:error-stop' has to be a top-level binding to be
|
||||
;; mutated by client programs --- actually, the test harness ---
|
||||
;; for exception handling.
|
||||
;; 2) Exception jumps by the test harness are performed through
|
||||
;; call/cc, not call/ec.
|
||||
;;
|
||||
;; Solution: use `namespace-variable-value', and create an escape
|
||||
;; continuation for each nested continuation.
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define esc-cont-mark-key (gensym))
|
||||
(define detect-tail-key (gensym))
|
||||
(define recovering-from-error (make-parameter #f))
|
||||
(define (mk-k k ek)
|
||||
(lambda args
|
||||
(apply (if (recovering-from-error) ek k) args)))
|
||||
;; Ugly:
|
||||
;;
|
||||
;; 1) `eopl:error-stop' has to be a top-level binding to be
|
||||
;; mutated by client programs --- actually, the test harness ---
|
||||
;; for exception handling.
|
||||
;; 2) Exception jumps by the test harness are performed through
|
||||
;; call/cc, not call/ec.
|
||||
;;
|
||||
;; Solution: use `namespace-variable-value', and create an escape
|
||||
;; continuation for each nested continuation.
|
||||
|
||||
(define (eopl:call-with-current-continuation f)
|
||||
(unless (and (procedure? f)
|
||||
(procedure-arity-includes? f 1))
|
||||
;; let call/cc report the error:
|
||||
(call/cc f))
|
||||
(let/cc k
|
||||
(let ([v (gensym)]
|
||||
[orig-marks (continuation-mark-set->list
|
||||
(continuation-marks k)
|
||||
detect-tail-key)])
|
||||
(with-continuation-mark detect-tail-key v
|
||||
(let ([new-marks (continuation-mark-set->list
|
||||
(current-continuation-marks)
|
||||
detect-tail-key)])
|
||||
(if (or (null? orig-marks)
|
||||
(and (pair? (cdr new-marks))
|
||||
(eq? (car orig-marks) (cadr new-marks))))
|
||||
;; Old mark surived => not tail wrt old call.
|
||||
;; Create an escape continuation to use for
|
||||
;; error escapes. Of course, we rely on the fact
|
||||
;; that continuation marks are not visible to EoPL
|
||||
;; programs.
|
||||
(let/ec ek
|
||||
(with-continuation-mark esc-cont-mark-key ek
|
||||
(with-continuation-mark detect-tail-key (gensym)
|
||||
(f (mk-k k ek)))))
|
||||
;; Old mark replaced => tail wrt old call.
|
||||
;; To preserve tail semantics for all but the first call
|
||||
;; reuse `mark' instead of creating a new escape continuation:
|
||||
(let ([mark (car (continuation-mark-set->list
|
||||
(continuation-marks k)
|
||||
esc-cont-mark-key))])
|
||||
(f (mk-k k mark)))))))))
|
||||
|
||||
(namespace-set-variable-value! 'eopl:error-stop #f #t)
|
||||
(define (install-eopl-exception-handler)
|
||||
(uncaught-exception-handler
|
||||
(let ([eh (uncaught-exception-handler)]
|
||||
[orig-namespace (current-namespace)])
|
||||
(lambda (x)
|
||||
(let ([v (with-handlers ([void (lambda (x) #f)])
|
||||
(parameterize ([current-namespace orig-namespace])
|
||||
(namespace-variable-value 'eopl:error-stop)))])
|
||||
(if v
|
||||
(parameterize ([recovering-from-error #t])
|
||||
(v))
|
||||
(eh x)))))))
|
||||
|
||||
(provide install-eopl-exception-handler)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define esc-cont-mark-key (gensym))
|
||||
(define detect-tail-key (gensym))
|
||||
(define recovering-from-error (make-parameter #f))
|
||||
(define (mk-k k ek)
|
||||
(lambda args
|
||||
(apply (if (recovering-from-error) ek k) args)))
|
||||
|
||||
(provide always? list-of maybe)
|
||||
(define (eopl:call-with-current-continuation f)
|
||||
(unless (and (procedure? f)
|
||||
(procedure-arity-includes? f 1))
|
||||
;; let call/cc report the error:
|
||||
(call/cc f))
|
||||
(let/cc k
|
||||
(let ([v (gensym)]
|
||||
[orig-marks (continuation-mark-set->list
|
||||
(continuation-marks k)
|
||||
detect-tail-key)])
|
||||
(with-continuation-mark detect-tail-key v
|
||||
(let ([new-marks (continuation-mark-set->list
|
||||
(current-continuation-marks)
|
||||
detect-tail-key)])
|
||||
(if (or (null? orig-marks)
|
||||
(and (pair? (cdr new-marks))
|
||||
(eq? (car orig-marks) (cadr new-marks))))
|
||||
;; Old mark surived => not tail wrt old call.
|
||||
;; Create an escape continuation to use for
|
||||
;; error escapes. Of course, we rely on the fact
|
||||
;; that continuation marks are not visible to EoPL
|
||||
;; programs.
|
||||
(let/ec ek
|
||||
(with-continuation-mark esc-cont-mark-key ek
|
||||
(with-continuation-mark detect-tail-key (gensym)
|
||||
(f (mk-k k ek)))))
|
||||
;; Old mark replaced => tail wrt old call.
|
||||
;; To preserve tail semantics for all but the first call
|
||||
;; reuse `mark' instead of creating a new escape continuation:
|
||||
(let ([mark (car (continuation-mark-set->list
|
||||
(continuation-marks k)
|
||||
esc-cont-mark-key))])
|
||||
(f (mk-k k mark)))))))))
|
||||
|
||||
(define always?
|
||||
(lambda (x) #t))
|
||||
(namespace-set-variable-value! 'eopl:error-stop #f #t)
|
||||
(define (install-eopl-exception-handler)
|
||||
(uncaught-exception-handler
|
||||
(let ([eh (uncaught-exception-handler)]
|
||||
[orig-namespace (current-namespace)])
|
||||
(lambda (x)
|
||||
(let ([v (with-handlers ([void (lambda (x) #f)])
|
||||
(parameterize ([current-namespace orig-namespace])
|
||||
(namespace-variable-value 'eopl:error-stop)))])
|
||||
(if v
|
||||
(parameterize ([recovering-from-error #t])
|
||||
(v))
|
||||
(eh x)))))))
|
||||
|
||||
(define list-of
|
||||
(lambda (pred . l)
|
||||
(let ((all-preds (cons pred l)))
|
||||
(lambda (obj)
|
||||
(let loop ((obj obj) (preds '()))
|
||||
(or
|
||||
;; if list is empty, preds should be, too
|
||||
(and (null? obj) (null? preds))
|
||||
(if (null? preds)
|
||||
;; if preds is empty, but list isn't, then recycle
|
||||
(loop obj all-preds)
|
||||
;; otherwise check and element and recur.
|
||||
(and (pair? obj)
|
||||
((car preds) (car obj))
|
||||
(loop (cdr obj) (cdr preds))))))))))
|
||||
|
||||
(define maybe
|
||||
(lambda (pred)
|
||||
(provide install-eopl-exception-handler)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(provide always? list-of maybe)
|
||||
|
||||
(define always?
|
||||
(lambda (x) #t))
|
||||
|
||||
(define list-of
|
||||
(lambda (pred . l)
|
||||
(let ((all-preds (cons pred l)))
|
||||
(lambda (obj)
|
||||
(or (pred obj)
|
||||
(eqv? obj #f)))))
|
||||
(let loop ((obj obj) (preds '()))
|
||||
(or
|
||||
;; if list is empty, preds should be, too
|
||||
(and (null? obj) (null? preds))
|
||||
(if (null? preds)
|
||||
;; if preds is empty, but list isn't, then recycle
|
||||
(loop obj all-preds)
|
||||
;; otherwise check and element and recur.
|
||||
(and (pair? obj)
|
||||
((car preds) (car obj))
|
||||
(loop (cdr obj) (cdr preds))))))))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define maybe
|
||||
(lambda (pred)
|
||||
(lambda (obj)
|
||||
(or (pred obj)
|
||||
(eqv? obj #f)))))
|
||||
|
||||
(define empty null)
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(provide time ;; useful to compare implementations
|
||||
collect-garbage ;; useful with `time'
|
||||
empty ;; for constructor-based printing
|
||||
trace untrace ;; debugging
|
||||
require module ;; we allow full use of modules
|
||||
provide ;; in case someone wants to use a module
|
||||
make-parameter
|
||||
parameterize
|
||||
print-struct)
|
||||
(define empty null)
|
||||
|
||||
(provide unquote unquote-splicing
|
||||
quote quasiquote if
|
||||
lambda letrec define-syntax delay let let* let-syntax letrec-syntax
|
||||
and or cond case do
|
||||
begin set!
|
||||
;; => else ; not bound in `mzscheme'
|
||||
(provide time ;; useful to compare implementations
|
||||
collect-garbage ;; useful with `time'
|
||||
empty ;; for constructor-based printing
|
||||
trace untrace ;; debugging
|
||||
require module ;; we allow full use of modules
|
||||
provide ;; in case someone wants to use a module
|
||||
make-parameter
|
||||
parameterize
|
||||
print-struct)
|
||||
|
||||
(rename #%plain-module-begin #%module-begin)
|
||||
#%app #%datum #%top #%top-interaction
|
||||
#%require #%provide #%expression
|
||||
(provide unquote unquote-splicing
|
||||
quote quasiquote if
|
||||
lambda letrec define-syntax delay let let* let-syntax letrec-syntax
|
||||
and or cond case do
|
||||
begin set!
|
||||
;; => else ; not bound in `mzscheme'
|
||||
|
||||
(for-syntax syntax-rules ...)
|
||||
cons car cdr pair? map for-each
|
||||
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
|
||||
= < > <= >= max min + - * /
|
||||
abs gcd lcm exp log sin cos tan not eq?
|
||||
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!
|
||||
string->list list->string
|
||||
vector-length vector-fill!
|
||||
vector->list 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
|
||||
apply symbol?
|
||||
null?
|
||||
list? list length append reverse list-tail
|
||||
list-ref memq memv member assq assv 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?
|
||||
read read-char peek-char eof-object?
|
||||
char-ready?
|
||||
write 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
|
||||
eval
|
||||
#|
|
||||
scheme-report-environment null-environment interaction-environment
|
||||
|#
|
||||
))
|
||||
(rename #%plain-module-begin #%module-begin)
|
||||
#%app #%datum #%top #%top-interaction
|
||||
#%require #%provide #%expression
|
||||
|
||||
(for-syntax syntax-rules ...)
|
||||
cons car cdr pair? map for-each
|
||||
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
|
||||
= < > <= >= max min + - * /
|
||||
abs gcd lcm exp log sin cos tan not eq?
|
||||
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!
|
||||
string->list list->string
|
||||
vector-length vector-fill!
|
||||
vector->list 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
|
||||
apply symbol?
|
||||
null?
|
||||
list? list length append reverse list-tail
|
||||
list-ref memq memv member assq assv 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?
|
||||
read read-char peek-char eof-object?
|
||||
char-ready?
|
||||
write 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
|
||||
eval
|
||||
#|
|
||||
scheme-report-environment null-environment interaction-environment
|
||||
|#
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user