working on the namespace errors due to the structure values coming from another module.

cs019/cs019-pre-base.rkt

@@ -9,10 +9,12 @@
          cs019-when
          cs019-unless
          cs019-set!
-         cs019-case)
+         cs019-case
+         cs019-local)
 
 (define-syntax cs019-define advanced-define/proc)
 (define-syntax cs019-lambda advanced-lambda/proc)
 (define-syntaxes (cs019-when cs019-unless) (values advanced-when/proc advanced-unless/proc))
 (define-syntax cs019-set! advanced-set!/proc)
-(define-syntax cs019-case advanced-case/proc)
+(define-syntax cs019-case advanced-case/proc)
+(define-syntax cs019-local intermediate-local/proc)

cs019/cs019.rkt

@@ -13,7 +13,8 @@
                      [cs019-define define]
                      [cs019-when when]
                      [cs019-unless unless]
-                     [cs019-case case]))
+                     [cs019-case case]
+                     [cs019-local local]))
 
 (require "private/sigs-patched.rkt")
 (provide [all-from-out "private/sigs-patched.rkt"])
@@ -44,7 +45,8 @@
                      define
                      lambda
                      unless
-                     when)
+                     when
+                     local)
 
          string-ith
          replicate

cs019/firstorder.rkt

@@ -0,0 +1,23 @@
+(module firstorder mzscheme
+
+  (provide make-first-order
+	   first-order->higher-order)
+
+  (define-values (struct:fo make-first-order fo? fo-get fo-set!)
+    (make-struct-type 'procedure #f 2 0 #f null (current-inspector) 0))  
+
+  (define fo-proc-id (make-struct-field-accessor fo-get 1))
+
+  (define (first-order->higher-order id)
+    (let ([v (syntax-local-value id (lambda () #f))])
+      (if (or (fo? v)
+              (and (set!-transformer? v)
+                   (fo? (set!-transformer-procedure v))))
+          (syntax-property
+           (syntax-local-introduce 
+            (fo-proc-id (if (fo? v) v (set!-transformer-procedure v))))
+           'disappeared-use
+           (syntax-local-introduce id))
+	  id))))
+
+

cs019/rewrite-error-message.rkt

@@ -0,0 +1,99 @@
+#lang scheme/base
+
+(require mzlib/etc
+         mzlib/list
+         (for-syntax "firstorder.rkt"
+                     scheme/base))
+
+(provide rewrite-contract-error-message
+         reraise-rewriten-lookup-error-message
+         get-rewriten-error-message
+         plural
+         raise-not-bound-error
+         argcount-error-message)
+
+(define (reraise-rewriten-lookup-error-message e id was-in-app-position)
+  (let ([var-or-function (if was-in-app-position "function" "variable")])
+    (raise-syntax-error
+     #f
+     (format "this ~a is not defined" var-or-function)
+     id)))
+
+(define (exn-needs-rewriting? exn)
+  (exn:fail:contract? exn))
+
+(define (ensure-number n-or-str)
+  (if (string? n-or-str) (string->number n-or-str) n-or-str))
+
+(define (plural n)
+  (if (> (ensure-number n) 1) "s" ""))
+
+(define (raise-not-bound-error id)
+  (if (syntax-property id 'was-in-app-position)
+      (raise-syntax-error
+       #f
+       "this function is not defined"
+       id)
+      (raise-syntax-error
+       #f
+       "this variable is not defined"
+       id)))
+
+(define (argcount-error-message arity found [at-least #f])
+  (define arity:n (ensure-number arity))
+  (define found:n (ensure-number found))
+  (define fn-is-large (> arity:n found:n))
+  (format "expects ~a~a~a argument~a, but found ~a~a"
+          (if at-least "at least " "")
+          (if (or (= arity:n 0) fn-is-large) "" "only ")
+          (if (= arity:n 0) "no" arity:n) (plural arity:n)
+          (if (and (not (= found:n 0)) fn-is-large) "only " "")
+          (if (= found:n 0) "none" found:n)))
+
+(define (rewrite-contract-error-message msg)
+  (define replacements
+    (list (list #rx"procedure application: expected procedure, given: (.*) \\(no arguments\\)"
+                (lambda (all one) 
+                  (format "function call: expected a function after the open parenthesis, but received ~a" one)))
+          (list #rx"procedure application: expected procedure, given: (.*); arguments were:.*"
+                (lambda (all one)  
+                  (format "function call: expected a function after the open parenthesis, but received ~a" one)))
+          (list #rx"expects argument of type (<([^>]+)>)"
+                (lambda (all one two) (format "expects a ~a" two)))
+          (list #rx"expected argument of type (<([^>]+)>)"
+                (lambda (all one two) (format "expects a ~a" two)))
+          (list #rx"expects type (<([^>]+)>)"
+                (lambda (all one two) (format "expects a ~a" two)))
+          (list #px"expects at least (\\d+) argument.?, given (\\d+)(: .*)?"
+                (lambda (all one two three) (argcount-error-message one two #t)))
+          (list #px"expects (\\d+) argument.?, given (\\d+)(: .*)?"
+                (lambda (all one two three) (argcount-error-message one two)))
+          (list #rx"^procedure "
+                (lambda (all) ""))
+          (list #rx", given: "
+                (lambda (all) ", given "))
+          (list #rx"; other arguments were:.*"
+                (lambda (all) ""))
+          (list #rx"expects a (struct:)"
+                (lambda (all one) "expects a "))
+          (list #rx"list or cyclic list"
+                (lambda (all) "list"))
+          (list (regexp-quote "given #(struct:object:image% ...)")
+                (lambda (all) "given an image"))
+          (list (regexp-quote "given #(struct:object:image-snip% ...)")
+                (lambda (all) "given an image"))
+          (list (regexp-quote "given #(struct:object:cache-image-snip% ...)")
+                (lambda (all) "given an image"))
+          (list (regexp-quote "#(struct:object:image% ...)")
+                (lambda (all) "(image)"))
+          (list (regexp-quote "#(struct:object:image-snip% ...)")
+                (lambda (all) "(image)"))
+          (list (regexp-quote "#(struct:object:cache-image-snip% ...)")
+                (lambda (all) "(image)"))))
+  (for/fold ([msg msg]) ([repl. replacements])
+    (regexp-replace* (first repl.) msg (second repl.))))
+
+(define (get-rewriten-error-message exn)
+  (if (exn-needs-rewriting? exn)
+      (rewrite-contract-error-message (exn-message exn))
+      (exn-message exn)))

cs019/teach-runtime.rkt

@@ -0,0 +1,14 @@
+#lang s-exp "../lang/base.rkt"
+
+(provide check-not-undefined)
+
+;; Wrapped around uses of local-bound variables:
+(define (check-not-undefined name val)
+  (if (eq? val undefined)
+      (raise
+       (make-exn:fail:contract:variable
+        (format "local variable used before its definition: ~a" name)
+        (current-continuation-marks)
+        name))
+      val))
+(define undefined (letrec ([x x]) x))

cs019/teach.rkt

@@ -1,8 +1,12 @@
 #lang racket/base
 
 (require (for-template "../lang/base.rkt")
+         (for-template "teach-runtime.rkt")
+         "teachhelp.rkt"
          stepper/private/shared
          racket/list
+         syntax/context
+         syntax/kerncase
          syntax/stx)
 
 
@@ -11,7 +15,19 @@
          advanced-when/proc
          advanced-unless/proc
          advanced-set!/proc advanced-set!-continue/proc
-         advanced-case/proc)
+         advanced-case/proc
+         intermediate-local/proc)
+
+
+
+  ;; verify-boolean is inserted to check for boolean results:
+  (define (verify-boolean b where)
+    (if (or (eq? b #t) (eq? b #f))
+      b
+      (raise
+       (make-exn:fail:contract
+        (format "~a: question result is not true or false: ~e" where b)
+        (current-continuation-marks)))))
 
 
 ;; A consistent pattern for stepper-skipto:
@@ -269,6 +285,178 @@
 
 
 
+
+
+
+
+
+
+
+
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; local
+    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (intermediate-local/proc stx)
+      (ensure-expression
+       stx
+       (lambda ()
+	 (syntax-case stx ()
+	   [(_ (definition ...) . exprs)
+	    (let ([defns (syntax->list (syntax (definition ...)))]
+		  ;; The following context value lets teaching-language definition
+		  ;;  forms know that it's ok to expand in this internal
+		  ;;  definition context.
+		  [int-def-ctx (build-expand-context (make-expanding-for-intermediate-local))])
+	      (let* ([partly-expand (lambda (d)
+                                      (local-expand
+                                       d
+                                       int-def-ctx
+                                       (kernel-form-identifier-list)))]
+                     [partly-expanded-defns
+		      (map partly-expand defns)]
+		     [flattened-defns
+		      (let loop ([l partly-expanded-defns][origs defns])
+			(apply
+			 append
+			 (map (lambda (d orig)
+				(syntax-case d (begin define-values define-syntaxes)
+				  ;; we don't have to check for ill-formed `define-values'
+				  ;; or `define-syntaxes', because only macros can generate
+				  ;; them
+				  [(begin defn ...)
+				   (let ([l (map partly-expand (syntax->list (syntax (defn ...))))])
+				     (loop l l))]
+				  [(define-values . _)
+				   (list d)]
+				  [(define-syntaxes . _)
+				   (list d)]
+				  [_else
+				   (teach-syntax-error
+				    'local
+				    stx
+				    orig
+				    "expected a definition, but found ~a"
+				    (something-else orig))]))
+			      l origs)))]
+		     [val-defns
+		      (apply
+		       append
+		       (map (lambda (partly-expanded)
+			      (syntax-case partly-expanded (define-values)
+				[(define-values (id ...) expr)
+				 (list partly-expanded)]
+				[_else
+				 null]))
+			    flattened-defns))]
+		     [stx-defns
+		      (apply
+		       append
+		       (map (lambda (partly-expanded)
+			      (syntax-case partly-expanded (define-syntaxes)
+				[(define-syntaxes (id ...) expr)
+				 (list partly-expanded)]
+				[_else
+				 null]))
+			    flattened-defns))]
+		     [get-ids (lambda (l)
+				(apply
+				 append
+				 (map (lambda (partly-expanded)
+					(syntax-case partly-expanded ()
+					  [(_ (id ...) expr)
+					   (syntax->list (syntax (id ...)))]))
+				      l)))]
+		     [val-ids (get-ids val-defns)]
+		     [stx-ids (get-ids stx-defns)])
+		(let ([dup (check-duplicate-identifier (append val-ids stx-ids))])
+		  (when dup
+		    (teach-syntax-error
+		     'local
+		     stx
+		     dup
+		     "~a was defined locally more than once"
+		     (syntax-e dup)))
+		  (let ([exprs (syntax->list (syntax exprs))])
+		    (check-single-expression 'local
+					     "after the local definitions"
+					     stx
+					     exprs
+					     (append val-ids stx-ids)))
+		  (with-syntax ([((d-v (def-id ...) def-expr) ...) val-defns]
+				[(stx-def ...) stx-defns])
+		    (with-syntax ([(((tmp-id def-id/prop) ...) ...)
+				   ;; Generate tmp-ids that at least look like the defined
+				   ;;  ids, for the purposes of error reporting, etc.:
+				   (map (lambda (def-ids)
+					  (map (lambda (def-id)
+						 (list
+						  (stepper-syntax-property
+						   (datum->syntax
+						    #f
+						    (string->uninterned-symbol
+						     (symbol->string (syntax-e def-id))))
+						   'stepper-orig-name
+						   def-id)
+						  (syntax-property
+						   def-id
+						   'bind-as-variable
+						   #t)))
+					       (syntax->list def-ids)))
+					(syntax->list (syntax ((def-id ...) ...))))])
+		      (with-syntax ([(mapping ...)
+				     (let ([mappers
+					    (syntax->list
+					     (syntax
+					      ((define-syntaxes (def-id/prop ...)
+						 (values
+						  (make-undefined-check
+						   (quote-syntax check-not-undefined)
+						   (quote-syntax tmp-id))
+						  ...))
+					       ...)))])
+				       (map syntax-track-origin
+					    mappers
+					    val-defns
+					    (syntax->list (syntax (d-v ...)))))])
+			(stepper-syntax-property
+			 (quasisyntax/loc stx
+			   (let ()
+                             (#%stratified-body
+                              (define #,(gensym) 1) ; this ensures that the expansion of 'local' looks
+					            ; roughly the same, even if the local has no defs.
+                              mapping ...
+                              stx-def ...
+                              (define-values (tmp-id ...) def-expr)
+                              ...
+                              . exprs)))
+			 'stepper-hint
+			 'comes-from-local)))))))]
+	   [(_ def-non-seq . __)
+	    (teach-syntax-error
+	     'local
+	     stx
+	     (syntax def-non-seq)
+	     "expected at least one definition (in square brackets) after local, but found ~a"
+	     (something-else (syntax def-non-seq)))]
+	   [(_)
+	    (teach-syntax-error
+	     'local
+	     stx
+	     #f
+             "expected at least one definition (in square brackets) after local, but nothing's there")]
+	   [_else (bad-use-error 'local stx)]))))
+
+
+
+
+
+
+
+
+
+
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; define (beginner)
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

lang/kernel.rkt

@@ -201,7 +201,12 @@
 
          exn:fail
          struct:exn:fail
-         prop:exn:srclocs)
+         prop:exn:srclocs
+
+
+         ;; needed for cs019-local
+         #%stratified-body
+         )
 
 
 (define (-identity x) x)

tests/more-tests/basics-cs019.rkt

@@ -0,0 +1,160 @@
+#lang planet dyoo/whalesong/cs019
+
+(define-struct f (x))
+(define-struct g (a b))
+(check-expect (build-list 5 add1) (list 1 2 3 4 5))
+(check-expect (make-g 1 2) (make-g 1 2))
+(check-expect (make-g 'b empty) (make-g 'b empty))
+
+(define i (open-image-url "http://racket-lang.org/logo.png"))
+(check-expect (image-height i) 85)
+(check-expect (image-width i) 88)
+
+;; Whalesong currently has no support for hashes.
+;(define ht (hash))
+;(define ht2 (hash-set ht "x" 10))
+;(check-expect(hash-ref ht2 "x") 10)
+;(check-error (hash-ref ht "x") "hash-ref: no value found for key: \"x\"")
+
+;; INSERTION SORT
+
+(define: (isort [l : (Listof: Number$)]) -> (Listof: Number$)
+  (cond
+    [(empty? l) l]
+    [(cons? l) (insert (first l)
+                       (isort (rest l)))]))
+
+(define: (insert [e : Number$] [l : (Listof: Number$)]) -> (Listof: Number$)
+  (cond
+    [(empty? l) (cons e l)]
+    [(cons? l) (if (<= e (first l))
+                   (cons e l)
+                   (cons (first l)
+                         (insert e (rest l))))]))
+
+(check-expect (isort (list 3 1 2 4)) (list 1 2 3 4))
+
+;; TREE ZIP
+
+;(struct: None ())
+;(struct: (a) Some ([v : a]))
+;(define-type (Opt a) (U None (Some a)))
+(define-struct: None ())
+(define-struct: Some ([v : Any$]))
+(define Opt$ (or: None$ Some$))
+
+;(struct: (a) Node ([value : a] [kids : (Listof (Tree a))]) #:transparent)
+;(struct: MtNode () #:transparent)
+;(define-type Tree (All (a) (U (Node a) MtNode)))
+(define-struct: Node ([value : Any$] [kids : (Listof: Tree$)]))
+(define-struct: MtNode ())
+(define Tree$ (or: Node$ MtNode$))
+
+;(struct: (a) BackPtr ([n : (Node a)] [p : Integer]) #:transparent)
+;(struct: (a) Cursor ([below : (Tree a)] [above : (Listof (BackPtr a))]) #:transparent)
+(define-struct: BackPtr ([n : Node$] [p : (Sig: integer?)]))
+(define-struct: Cursor ([below : Tree$] [above : (Listof: BackPtr$)]))
+
+(define Opt-Cursor$ (Sig: (lambda (v)
+                            (or (None? v)
+                                (and (Some? v)
+                                     (Cursor? (Some-v v)))))))
+
+;(: find (All (a) ((Tree a) (a -> Boolean) -> (Cursor a))))
+(define: (find [t : Tree$] [p : (Any$ -> Boolean$)]) -> Cursor$
+  (local
+    [
+     ;(: find-helper (All (a) ((Tree a) (Listof (BackPtr a)) -> (Opt (Cursor a)))))
+     (define: (find-helper [t : Tree$] [above : (Listof: BackPtr$)]) -> Opt-Cursor$
+       (cond
+         [(MtNode? t) (make-None)]
+         [(Node? t)
+          (if (p (Node-value t))
+              (make-Some (make-Cursor t above))
+              (let ([v (search-kids (Node-kids t) 0 t above)])
+                (if (Some? v) v (make-None))))]))
+
+;       (: search-kids (All (a) ((Listof (Tree a)) 
+;                           Integer
+;                           (Node a)
+;                           (Listof (BackPtr a)) -> (Opt (Cursor a)))))
+     (define: (search-kids [kids : (Listof: Tree$)]
+                           [n : (Sig: integer?)]
+                           [first-above : Node$]
+                           [rest-above : (Listof: BackPtr$)]) -> Opt-Cursor$
+       (cond
+         [(empty? kids) (make-None)]
+         [(cons? kids)
+          (let ([v (find-helper (first kids) 
+                                (cons (make-BackPtr first-above n) rest-above))])
+            (if (Some? v) 
+                v
+                (search-kids (rest kids) (add1 n) first-above rest-above)))]))
+     ]
+    (let ([v (find-helper t empty)])
+      (if (None? v) (error 'find "no such node") (Some-v v)))))
+
+;(: down (All (a) ((Cursor a) Integer -> (Cursor a))))
+(define: (down [c : Cursor$] [n : (Sig: integer?)]) -> Cursor$
+  (let ([v (Cursor-below c)])
+    (cond
+      [(MtNode? v) (error 'down "impossible to go down")]
+      [(Node? v)
+       (if (empty? (Node-kids v))
+           (error 'down "impossible to go down")
+           (make-Cursor (list-ref (Node-kids v) n)
+                        (cons (make-BackPtr v n) (Cursor-above c))))])))
+
+;(: replace (All (a) ((Cursor a) (Tree a) -> (Cursor a))))
+(define: (replace [c : Any$] [t : Tree$]) -> Cursor$
+  (make-Cursor t (Cursor-above c)))
+
+;(: reconstruct/1 (All (a) ((BackPtr a) (Tree a) -> (Node a))))
+(define: (reconstruct/1 [one-up : BackPtr$] [replace-with : Tree$]) -> Node$
+  (let ([node (BackPtr-n one-up)]
+        [posn (BackPtr-p one-up)])
+    (let ([val (Node-value node)]
+          [kids (Node-kids node)])
+      (make-Node val
+                 (build-list (length kids)
+                             (lambda: ([i : (Sig: integer?)]) -> Tree$
+                                      (if (= i posn)
+                                          replace-with
+                                          (list-ref kids i))))))))
+
+;(: up (All (a) ((Cursor a) -> (Cursor a))))
+(define: (up [c : Cursor$]) -> Cursor$
+  (if (empty? (Cursor-above c))
+      (error 'up "impossible to go up")
+      (make-Cursor (reconstruct/1 (first (Cursor-above c))
+                                  (Cursor-below c))
+                   (rest (Cursor-above c)))))
+
+;(: ->tree (All (a) ((Cursor a) -> (Tree a))))
+(define: (->tree [c : Cursor$]) -> Tree$
+  (if (empty? (Cursor-above c))
+      (Cursor-below c)
+      (->tree (up c))))
+
+(define T (make-Node 7 (list (make-Node 3 empty) (make-MtNode) (make-Node 5 empty))))
+(define c0 (find T (lambda: ([n : (Sig: integer?)]) -> Boolean$ (= n 3))))
+(define c2 (find T (lambda: ([n : (Sig: integer?)]) -> Boolean$ (= n 5))))
+(define c3                (replace (down (up c0) 1) T)             )
+(define c4 (replace (down (replace (down (up c0) 1) T) 0) (make-MtNode)))
+
+(check-expect T (->tree c0))
+(check-expect T (->tree c2))
+(check-expect (->tree c3)
+              (make-Node 7
+                         (list (make-Node 3 empty)
+                               (make-Node 7 (list (make-Node 3 empty)
+                                                  (make-MtNode)
+                                                  (make-Node 5 empty)))
+                               (make-Node 5 empty))))
+(check-expect (->tree c4)
+              (make-Node 7
+                         (list (make-Node 3 empty)
+                               (make-Node 7 (list (make-MtNode)
+                                                  (make-MtNode)
+                                                  (make-Node 5 empty)))
+                               (make-Node 5 empty))))