#lang mzscheme (require "datatype.ss" "private/sllgen.ss" mzlib/trace mzlib/pretty) (require-for-syntax "private/slldef.ss") (provide define-datatype cases) ;; 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 (rename eopl-define define)) (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))) (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) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (provide always? list-of maybe) (define always? (lambda (x) #t)) (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) (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) (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' (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-ci? vector? make-vector vector vector-ref vector-set! char? char=? char? char<=? char>=? 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 |# )