From 20fcb6314c01662ca6e747a3013f28ad8a7173e7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 12 Jun 2008 13:02:41 +0000 Subject: [PATCH] honu-module -> honu; misc doc and slideshow tweaks svn: r10230 --- collects/honu-module/doc.txt | 157 ------------------ collects/honu/lang/reader.ss | 16 ++ .../honu-module.ss => honu/main.ss} | 48 ++++-- .../{honu-module => honu}/private/contexts.ss | 0 .../{honu-module => honu}/private/mzscheme.ss | 0 collects/{honu-module => honu}/private/ops.ss | 0 .../{honu-module => honu}/private/util.ss | 0 .../contracts/contracts-module-begin.ss | 4 +- collects/lang/private/teach.ss | 11 +- collects/lazy/lazy.scrbl | 84 +++++++++- .../scribblings/reference/filesystem.scrbl | 4 +- collects/scribblings/reference/syntax.scrbl | 4 +- collects/scribblings/slideshow/picts.scrbl | 8 +- collects/setup/setup-unit.ss | 6 +- collects/texpict/face.ss | 19 ++- 15 files changed, 162 insertions(+), 199 deletions(-) delete mode 100644 collects/honu-module/doc.txt create mode 100644 collects/honu/lang/reader.ss rename collects/{honu-module/honu-module.ss => honu/main.ss} (98%) rename collects/{honu-module => honu}/private/contexts.ss (100%) rename collects/{honu-module => honu}/private/mzscheme.ss (100%) rename collects/{honu-module => honu}/private/ops.ss (100%) rename collects/{honu-module => honu}/private/util.ss (100%) diff --git a/collects/honu-module/doc.txt b/collects/honu-module/doc.txt deleted file mode 100644 index 423a0977e5..0000000000 --- a/collects/honu-module/doc.txt +++ /dev/null @@ -1,157 +0,0 @@ - ->>> FOR NOW, THIS IS AN EXPERIMENTAL TOY <<< - > Everything is subject to change. < - -Honu is a "gradual-ly typed" language. That is, it's statically typed, -but any expression can have type `obj', and an expresion of type `obj' -is implicitly coreced to any other type by inserting run-time checks -(with delayed checks for higher-order values, as in a contract -system). - -Every identifier binding has a declared type --- it's `obj' if an -optional is omitted --- and every function has a declared -return type. Types for expressions are inferred in the obvious -way. [TODO: explain "obvious".] - -The syntax is much like Java, but also slightly influenced by -Javascript, since functions are first-class values. Honu support -higher-order parametric polymorphism, for which it uses the Java -"generic" terminology. - -There no no classes/records, yet. That's the next step. - - -Write a Honu program as - - #honu - - - ... - -and run it like a `(module ...)' program. - -Each as a top-level is implicitly wrapped to print -the result of the (if the result is not void). - -The following grammar is a lie, because Honu is extensible in a way -that doesn't fit BNFs. But it's (intended as) an accurate picture of -the initial grammar before any extensions. - -Types: - - := obj // anything - | bool - | int // exact integer - | string // character string - | (* -> ) // procedure - | (* >-> ) // generic - | // if bound as generic argument - -Definitions: - - := var [] = ; // defaults to `obj' - | const [] = ; // prohibits assignment - | = ; - | id(,*) { * } - | < ,* > id(,*) { * } - - := // same as `obj ' - | - -The form is a generic-procedure definition. - -Expressions: - - := - | - | - | - | () - | { * } - | (type) // cast - | (,*) // procedure call - | [ ] // array access (eventually) - | < ,* > // generic instantiation - | [type] function(,*) { * } // anon function - | < ,* > [type] function(,*) { * } - - := - | - | true | false - - := + | - | * | / | % - | == | < | > | >= | <= | = - | && | || - | ? | : // see note below - - Operators have the same precedence as in Java - - Note: ` ? : ' is currently parsed as - `( ? ( : ))', where `?' looks for - `:' in its second argument. - -Statements: - - := - | // in non-tail positions, only - - := ; - | if () - | if () else - | return // in tail positions, only - | time ; - - := { * } - | - -Imports and exports: - - := - | provide ,* ; - ------------------------------------------------------------------------- - -About Honu Parsing and Typechecking ------------------------------------ - -A Honu program is first parsed by using the MzScheme reader, which -goes into H-expression mode due to the leading #honu. This read phase -tokenizes and groups based on parens, braces, brackets, and (under -certain circumstances) angle brackets. See the MzScheme manual for -details. - -The program is then parsed, expanded (including translation to -Scheme), and type-checked all at once. Thus, the parsing of a term can -depend on the type assigned by the context. - -Parsing proceeds by taking the first thing in the reader's output and -checking whether it has a binding as a Honu transformer. For example -`int' will have a binding to a transformer that expands the next bit -of the stream to a variable or function definition. This transformer -check is performed when the stream starts with an identifier or a -parenthesized group ( ...) includes only one operator -identifier; in the latter case, the operator is used for looking up a -transformer. For example, `(int -> int)' starts a definition because -`->' is bound to a transformer. - -A transformer takes the current stream and a context object; it -returns a Scheme expression and the unconsumed part of the stream. The -Scheme expression is likely to contain unparsed H-expression -representations in a `honu-unparsed-block' form, which is bound to a -Scheme macro in the usual way to continue parsing later. - -A context object can be anything. The base Honu grammar implies -several kinds of contexts, each with its own record type (described -later). A transformer should expand only in contexts that it -recognizes, and it should raise a syntax error when given any context -that it doesn't recognize. A transformer might expand differently in -different contexts. For example, `int' expands to a definition in a -block context (e.g., at the top level), but to a type description in a -type context (e.g., in a procedure's formal argument list). - -When the start of the stream offers no other guidance, it is parsed as -an expression. The expression-parsing rules are essentially hardwired -to the Java grammar rules. (In the future, programmers will likely -have control over precedence, at least.) - -[to be continued] diff --git a/collects/honu/lang/reader.ss b/collects/honu/lang/reader.ss new file mode 100644 index 0000000000..2eef6f0cd8 --- /dev/null +++ b/collects/honu/lang/reader.ss @@ -0,0 +1,16 @@ + +(module reader scheme/base + (require (only-in syntax/module-reader wrap-read-all)) + (provide (rename-out [*read read] + [*read-syntax read-syntax])) + + (define (*read in modpath line col pos) + (wrap in read-honu modpath #f line col pos)) + + (define (*read-syntax src in modpath line col pos) + (wrap in (lambda (in) + (read-honu-syntax src in)) + modpath src line col pos)) + + (define (wrap port read modpath src line col pos) + (wrap-read-all 'honu port read modpath src line col pos))) diff --git a/collects/honu-module/honu-module.ss b/collects/honu/main.ss similarity index 98% rename from collects/honu-module/honu-module.ss rename to collects/honu/main.ss index 50b5fa6a28..e410ba8448 100644 --- a/collects/honu-module/honu-module.ss +++ b/collects/honu/main.ss @@ -1,4 +1,4 @@ -(module honu-module "private/mzscheme.ss" +(module main "private/mzscheme.ss" (require-for-syntax syntax/stx "private/ops.ss" @@ -767,7 +767,7 @@ (define-syntax arg-id (make-honu-type #'arg-pred-id stx-car #'arg-name-id #f)) ... (honu-unparsed-type-predicate #,>->-stx next-pred res-type-name . #,result-stx) (let ([v ((generic-val v) safe? arg-pred-id ... arg-name-id ...)]) - (check #f #f res-type-name next-pred v))))) + (check* #f #f res-type-name next-pred v))))) ;; Not a generic (values #f #f))) ;; generics always protect themselves, for now: @@ -927,17 +927,17 @@ (define (check proc who type-name pred val) (let-values ([(tst new-val) (pred val)]) (unless tst - (raise - (make-exn:fail:contract - (format "~a: expected `~a' value for ~a, got something else: ~e" + (raise + (make-exn:fail:contract + (format "~a: expected `~a' value for ~a, got something else: ~e" (or proc (if (eq? who #t) #f who) "procedure") type-name (cond [(eq? who #t) "result"] [else (if proc - (format "`~a' argument" who) - (if who "initialization" "argument"))]) + (format "`~a' argument" who) + (if who "initialization" "argument"))]) val) - (current-continuation-marks)))) + (current-continuation-marks)))) new-val)) (define-syntax as-protected @@ -1017,7 +1017,7 @@ v)) ;; Need a run-time check: (with-syntax ([val v]) - #'(check proc who type-name-expr pred val))))] + #'(check* proc who type-name-expr pred val))))] [(if test-expr then-expr else-expr) (if (eq? #t (syntax-e #'type-name)) ;; Context guarantees correct use, but we have to manage any @@ -1086,7 +1086,13 @@ v ;; Run-time check: (with-syntax ([val v]) - #'(check proc who type-name-expr pred val))))]))])) + #'(check* proc who type-name-expr pred val))))]))])) + + (define-syntax check* + (syntax-rules () + [(_ proc who type-name #f val) val] + [(_ proc who type-name pred val) + (check proc who type-name pred val)])) (define-syntax (honu-app stx) (syntax-case stx () @@ -1099,9 +1105,13 @@ (if (= (length (syntax->list #'(arg-type ...))) (length (syntax->list #'(b ...)))) ;; Some run-time checks maybe needed on some arguments: - #'(honu-typed (pack-a-expr (check-expr-type #f #f arg-type arg-type-name arg-pred b) ...) - orig-expr - result-type result-protect-id) + (with-syntax ([app + (syntax/loc stx + (pack-a-expr (check-expr-type #f #f arg-type arg-type-name arg-pred b) ...))]) + (syntax/loc stx + (honu-typed app + orig-expr + result-type result-protect-id))) (raise-syntax-error #f (format (string-append "static type mismatch: " @@ -1114,7 +1124,8 @@ ;; There will be a run-time check to make sure that a is the ;; right kind of function, etc., and it will take care of the ;; argument checks itself. - #'(#%app (honu-typed pack-a-expr orig-a-expr a-type a-protect-id) b ...)] + (syntax/loc stx + (#%app (honu-typed pack-a-expr orig-a-expr a-type a-protect-id) b ...))] [_else (type-mismatch #'orig-a-expr #'a-type #'(-> (.... #f) (.... #f #f)))]))])) @@ -1178,11 +1189,14 @@ [(set! id rhs) (if const? (raise-syntax-error #f "cannot assign to constant" #'id) - #'(set! gen-id (check-expr-type 'set! id type-name type-name-expr pred-id rhs)))] + (syntax/loc stx + (set! gen-id (check-expr-type 'set! id type-name type-name-expr pred-id rhs))))] [(id arg (... ...)) - #'(honu-app (honu-typed gen-id id type-name protect-id) arg (... ...))] + (syntax/loc stx + (honu-app (honu-typed gen-id id type-name protect-id) arg (... ...)))] [id - #'(honu-typed gen-id id type-name protect-id)]))))))])) + (syntax/loc stx + (honu-typed gen-id id type-name protect-id))]))))))])) (define-for-syntax (make-typed-procedure gen-id result-spec arg-spec protect-id) (with-syntax ([((arg arg-type arg-type-name arg-pred-id) ...) arg-spec] diff --git a/collects/honu-module/private/contexts.ss b/collects/honu/private/contexts.ss similarity index 100% rename from collects/honu-module/private/contexts.ss rename to collects/honu/private/contexts.ss diff --git a/collects/honu-module/private/mzscheme.ss b/collects/honu/private/mzscheme.ss similarity index 100% rename from collects/honu-module/private/mzscheme.ss rename to collects/honu/private/mzscheme.ss diff --git a/collects/honu-module/private/ops.ss b/collects/honu/private/ops.ss similarity index 100% rename from collects/honu-module/private/ops.ss rename to collects/honu/private/ops.ss diff --git a/collects/honu-module/private/util.ss b/collects/honu/private/util.ss similarity index 100% rename from collects/honu-module/private/util.ss rename to collects/honu/private/util.ss diff --git a/collects/lang/private/contracts/contracts-module-begin.ss b/collects/lang/private/contracts/contracts-module-begin.ss index be3ccf7e11..fdb8bd28f9 100644 --- a/collects/lang/private/contracts/contracts-module-begin.ss +++ b/collects/lang/private/contracts/contracts-module-begin.ss @@ -251,7 +251,9 @@ [(define-values-for-syntax . _) #`(begin #,e2 (frm e1s e3s def-ids))] [(begin b1 ...) - #`(frm e1s (b1 ... . e3s) def-ids)] + (syntax-track-origin #`(frm e1s (b1 ... . e3s) def-ids) + e2 + (car (syntax-e e2)))] [(define-values (id ...) . _) #`(frm (#,e2 . e1s) e3s (id ... . def-ids))] [_ diff --git a/collects/lang/private/teach.ss b/collects/lang/private/teach.ss index 8719eecb67..cc554f5494 100644 --- a/collects/lang/private/teach.ss +++ b/collects/lang/private/teach.ss @@ -459,10 +459,13 @@ stx (define name #,(stepper-syntax-property - #`(lambda arg-seq - #,(stepper-syntax-property #`make-lambda-generative - 'stepper-skip-completely #t) - lexpr ...) + (syntax-track-origin + #`(lambda arg-seq + #,(stepper-syntax-property #`make-lambda-generative + 'stepper-skip-completely #t) + lexpr ...) + lam + (syntax-local-introduce (car (syntax-e lam)))) 'stepper-define-type 'lambda-define))))))]) (check-definition-new diff --git a/collects/lazy/lazy.scrbl b/collects/lazy/lazy.scrbl index d93bdf4f52..e325d8d27f 100644 --- a/collects/lazy/lazy.scrbl +++ b/collects/lazy/lazy.scrbl @@ -1,6 +1,5 @@ #lang scribble/doc -@(require (for-label scheme/base - scheme/contract +@(require (for-label (except-in lazy delay force promise?) (only-in lazy/force ! !! !!! !list !!list @@ -17,6 +16,32 @@ (define scheme-promise? (scheme promise?)))) (def-scheme scheme-force scheme-delay scheme-promise?)) +@(define-syntax-rule (deflazy mod def id) + (begin + (def-mz-req mod id mz-id) + @def[id]{Lazy variant of @|mz-id|.})) + +@(define-syntax-rule (def-mz-req mod id in-mz-id) + (begin + (define-syntax-rule (intro mz-id) + (begin + (require (for-label (only-in mod id))) + (define mz-id (scheme id)))) + (intro in-mz-id))) + +@(define-syntax-rule (defprocthing* mod id ...) + (begin + (deflazy mod defprocthing id) + ...)) + +@(define-syntax-rule (defprocthing id . rest) + (defthing id procedure? . rest)) + +@(define-syntax-rule (defidform* mod id ...) + (begin + (deflazy mod defidform id) + ...)) + @; ---------------------------------------- @(require scribble/manual) @@ -31,7 +56,7 @@ can be used to write lazy code. To write lazy code, simply use @schememod[ lazy -... lazy code here...] +... #, @elem{lazy code here}...] Function applications are delayed, and promises are automatically forced. The language provides bindings that are equivalent to most of @@ -61,11 +86,60 @@ change (or be dropped) in the future. There are a few additional bindings, the important ones are special forms that force strict behaviour---there are several of these that -are useful in forcing different parts of a value in different ways. +are useful in forcing different parts of a value in different ways, as +described in @secref["forcing"]. @; ---------------------------------------- -@section{Forcing Values} +@section{Lazy Forms and Functions} + +@defidform*[mzscheme +lambda +define +] + +@defidform*[scheme +let +let* +letrec +parameterize +define-values +let-values +let*-values +letrec-values +if +set! +begin begin0 when unless +cond case +] + +@defprocthing*[scheme + values make-struct-type + cons list list* vector box + and or + set-mcar! set-mcdr! vector-set! set-box! + error printf fprintf display write print + eq? eqv? equal? + list? length list-ref list-tail append map for-each andmap ormap + member memq memv assoc assq assv reverse + 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 + first second third fourth fifth sixth seventh eighth rest cons? empty empty? + foldl foldr last-pair remove remq remv remove* remq* remv* memf assf filter + sort + true false boolean=? symbol=? compose build-list + take +] + +@defprocthing[identity]{Lazy identity function.} + +@defprocthing[cycle]{Creates a lazy infinite list given a list of +elements to repeat in order.} + +@; ---------------------------------------- + +@section[#:tag "forcing"]{Forcing Values} @defmodule[lazy/force] diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl index 9b02e0380e..b927f200f5 100644 --- a/collects/scribblings/reference/filesystem.scrbl +++ b/collects/scribblings/reference/filesystem.scrbl @@ -264,8 +264,8 @@ Returns the file or directory's last modification date as platform-specific seconds (see also @secref["time"]) when @scheme[secs-n] is not provided or is @scheme[#f]. (For FAT filesystems under Windows, directories do not have modification -dates. Therefore, the creation date is returned for a directory (but -the modification date is returned for a file).) +dates. Therefore, the creation date is returned for a directory, but +the modification date is returned for a file.) If @scheme[secs-n] is provided and not @scheme[#f], the access and modification times of @scheme[path] are set to the given time. diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 466d58a248..f8ba8bd6fb 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -248,8 +248,8 @@ pre-defined forms are as follows. @defsubform[(only-in require-spec id-maybe-renamed ...)]{ Like @scheme[require-spec], but constrained to those exports for which the identifiers to bind match @scheme[id-maybe-renamed]: as - @scheme[id] or as @scheme[orig-id] in @scheme[[orig-id bind-id]]. If - the @scheme[id] of @scheme[orig-id] of any @scheme[id-maybe-renamed] + @scheme[_id] or as @scheme[_orig-id] in @scheme[[_orig-id _bind-id]]. If + the @scheme[_id] or @scheme[_orig-id] of any @scheme[id-maybe-renamed] is not in the set that @scheme[require-spec] describes, a syntax error is reported.} diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index 4792af2ded..246830b444 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -681,7 +681,7 @@ library provides functions for creating and placing cartoon-speech balloons.} @defproc[(wrap-balloon [pict pict?] - [spike one-of/c ('n 's 'e 'w 'ne 'se 'sw 'nw)] + [spike (one-of/c ('n 's 'e 'w 'ne 'se 'sw 'nw))] [dx real?] [dy real?] [color (or/c string? (is-a?/c color%)) balloon-color] @@ -810,8 +810,8 @@ follows: }} @defproc[(face* [eyebrow-kind (one-of/c 'none 'normal 'worried 'angry)] - [mouth-kind (one-of/c 'plain 'narrow 'medium 'large 'huge - 'grimace 'oh 'tongue)] + [mouth-kind (one-of/c 'plain 'smaller 'narrow 'medium 'large + 'huge 'grimace 'oh 'tongue)] [frown? any/c] [color (or/c string (is-a?/c color%))] [eye-inset real?] @@ -832,7 +832,7 @@ Returns a pict for a face: @item{@scheme[eyebrow-kind] determines the eyebrow shape.} - @item{@scheme[mouth-kind] determines the mouth shape, sombined with + @item{@scheme[mouth-kind] determines the mouth shape, combined with @scheme[frown?].} @item{@scheme[frown?] determines whether the mouth is up or down.} diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss index 8a4d3de197..1018ec91e0 100644 --- a/collects/setup/setup-unit.ss +++ b/collects/setup/setup-unit.ss @@ -99,7 +99,11 @@ (define (record-error cc desc go fail-k) (with-handlers ([exn:fail? (lambda (x) - (fprintf (current-error-port) "~a\n" (exn->string x)) + (if (verbose) + ((error-display-handler) + (format "~a\n" (exn->string x)) + x) + (fprintf (current-error-port) "~a\n" (exn->string x))) (set! errors (cons (list cc desc x) errors)) (fail-k))]) (go))) diff --git a/collects/texpict/face.ss b/collects/texpict/face.ss index 8ece5b64e5..9681082291 100644 --- a/collects/texpict/face.ss +++ b/collects/texpict/face.ss @@ -107,15 +107,16 @@ (* sw 2/3) (+ (if flip? 0 i) (* h 2/3)) (- (* pi (- 5/4 (if flip? 1 0))) da) (+ (* pi (- 7/4 (if flip? 1 0))) da))) - (define (plain-smile flip? tongue?) + (define (plain-smile flip? tongue? narrow?) (send dc set-brush no-brush) (series dc (if mouth-shading? 3 0) (make-object color% "black") face-edge-color (lambda (i) - (smile w h i 0 #f 0 flip?) - (smile w h (+ 1 (- i)) 0 #f 0 flip?)) + (let ([da (if narrow? (* pi -1/8) 0)]) + (smile w h i da #f 0 flip?) + (smile w h (+ 1 (- i)) da #f 0 flip?))) #t #f) (when tongue? (let ([path (new dc-path%)] @@ -243,7 +244,12 @@ (define (medium-grimace flip?) (grimace - (* 1.2 w) (* h 0.9) (- (* 0.1 pi)) + (* 1.2 w) (* h 0.9) (- (* 0.1 pi)) + flip?)) + + (define (narrow-grimace flip?) + (grimace + (* 1.2 w) (* h 0.9) (- (* 0.1 pi)) 15 flip?)) (define (large-smile flip?) @@ -327,14 +333,15 @@ [(angry) (angry-eyebrows eyebrow-dy)] [(none) (void)]) (case mouth-kind - [(plain) (plain-smile frown? #f)] + [(plain) (plain-smile frown? #f #f)] + [(smaller) (plain-smile frown? #f #t)] [(narrow) (narrow-smile frown?)] [(medium) (medium-smile frown?)] [(large) (large-smile frown?)] [(huge) (largest-smile frown?)] [(grimace) (medium-grimace frown?)] [(oh) (oh)] - [(tongue) (plain-smile frown? #t)]) + [(tongue) (plain-smile frown? #t #f)]) (send dc set-brush old-brush) (send dc set-pen old-pen))