diff --git a/collects/eopl/eopl.ss b/collects/eopl/eopl.ss index c46727c0e7..de4b3004a7 100644 --- a/collects/eopl/eopl.ss +++ b/collects/eopl/eopl.ss @@ -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-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 - |# - )) + (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 + |# + )