syntax-lambda; repl catches errors

src/k.sf

@@ -169,6 +169,7 @@
 ;  <core> -> (set& <id>)
 ;  <core> -> (lambda <ids> <core>) where <ids> -> (<id> ...) | (<id> ... . <id>) | <id>
 ;  <core> -> (lambda* (<arity> <core>) ...) where <arity> -> (<cnt> <rest?>)
+;  <core> -> (syntax-lambda (<id> ...) <core>)
 ;  <core> -> (letcc <id> <core>) 
 ;  <core> -> (withcc <core> <core>) 
 ;  <core> -> (begin <core> ...)
@@ -229,8 +230,9 @@
 ; <binding>     ->  (<symbol> . <value>)
 ; <value>       ->  <special> | <core>
 ; <special>     ->  <builtin> | <transformer>
-; <builtin>     ->  syntax | define | define-syntax |
+; <builtin>     ->  syntax | quote | set! | set& | begin | if | lambda | 
-;                   quote | set! | begin | if | lambda | body
+;                   lambda* | syntax-lambda | letcc | withcc | body | 
+;                   define | define-syntax ; top-level only
 ; <transformer> ->  <procedure of exp and env returning exp>
 
 (define-inline (val-core? val)            (pair? val))
@@ -260,7 +262,7 @@
   (extend-xenv env var (make-binding (id->sym var) (list 'ref val))))
 
 (define (x-error msg . args)
-  (apply error (cons (string-append "transformer: " msg) args)))
+  (error* (string-append "transformer: " msg) args))
 
 ; xform receives Scheme s-expressions and returns either Core Scheme <core>
 ; (always a pair) or special-form, which is either a builtin (a symbol) or
@@ -289,6 +291,7 @@
              [(if)            (xform-if            tail env)]
              [(lambda)        (xform-lambda        tail env)]
              [(lambda*)       (xform-lambda*       tail env)]
+             [(syntax-lambda) (xform-syntax-lambda tail env)]
              [(letcc)         (xform-letcc         tail env)]
              [(withcc)        (xform-withcc        tail env)]
              [(body)          (xform-body          tail env)]
@@ -379,15 +382,15 @@
   (if (and (list1+? tail) (idslist? (car tail)))
       (let loop ([vars (car tail)] [ienv env] [ipars '()])
         (cond [(pair? vars)
-              (let* ([var (car vars)] [nvar (gensym (id->sym var))])
+               (let* ([var (car vars)] [nvar (gensym (id->sym var))])
-                (loop (cdr vars) (add-var var nvar ienv) (cons nvar ipars)))]
+                 (loop (cdr vars) (add-var var nvar ienv) (cons nvar ipars)))]
               [(null? vars)
-              (list 'lambda (reverse ipars) (xform-body (cdr tail) ienv))]
+               (list 'lambda (reverse ipars) (xform-body (cdr tail) ienv))]
               [else ; improper 
                (let* ([var vars] [nvar (gensym (id->sym var))] 
                       [ienv (add-var var nvar ienv)])
-                (list 'lambda (append (reverse ipars) nvar)
+                 (list 'lambda (append (reverse ipars) nvar)
-                  (xform-body (cdr tail) ienv)))]))
+                   (xform-body (cdr tail) ienv)))]))
       (x-error "improper lambda body" (cons 'lambda tail))))
 
 (define (xform-lambda* tail env)
@@ -395,7 +398,9 @@
       (cons 'lambda*
          (map (lambda (aexp)
                  (if (and (list2? aexp) 
-                          (or (and (list2? (car aexp)) (fixnum? (caar aexp)) (boolean? (cadar aexp)))
+                          (or (and (list2? (car aexp)) 
+                                   (fixnum? (caar aexp)) 
+                                   (boolean? (cadar aexp)))
                               (idslist? (car aexp))))
                      (list (normalize-arity (car aexp))
                            (xform #f (cadr aexp) env))
@@ -403,6 +408,21 @@
               tail))
       (x-error "improper lambda* form" (cons 'lambda* tail))))
 
+(define (xform-syntax-lambda tail env)
+  (if (and (list2+? tail) (andmap id? (car tail)))
+      (let ([vars (car tail)] [macenv env] [forms (cdr tail)])
+        ; return a transformer that wraps xformed body in (syntax ...)
+        (lambda (use useenv)
+          (if (and (list1+? use) (fx=? (length vars) (length (cdr use))))
+              (let loop ([vars vars] [exps (cdr use)] [env macenv])
+                (if (null? vars)
+                    (list 'syntax (xform-body forms env))
+                    (loop (cdr vars) (cdr exps)
+                      (add-binding (car vars) 
+                        (xform #t (car exps) useenv) env))))  
+              (x-error "invalif syntax-lambda application" use))))  
+      (x-error "improper syntax-lambda body" (cons 'syntax-lambda tail))))
+
 (define (xform-letcc tail env)
   (if (and (list2+? tail) (id? (car tail)))
       (let* ([var (car tail)] [nvar (gensym (id->sym var))])
@@ -486,6 +506,7 @@
     (make-binding 'set& 'set&)
     (make-binding 'lambda 'lambda)
     (make-binding 'lambda* 'lambda*)
+    (make-binding 'syntax-lambda 'syntax-lambda)
     (make-binding 'letcc 'letcc)
     (make-binding 'withcc 'withcc)
     (make-binding 'begin 'begin)
@@ -785,7 +806,7 @@
 ;---------------------------------------------------------------------------------------------
 
 (define (c-error msg . args)
-  (apply error (cons (string-append "compiler: " msg) args)))
+  (error* (string-append "compiler: " msg) args))
 
 (define (write-serialized-char x port)
   (cond [(or (char=? x #\%) (char=? x #\") (char=? x #\\) (char<? x #\space) (char>? x #\~))
@@ -1535,6 +1556,16 @@
 
 (define *verbose* #f)
 
+(define *reset* #f)
+
+(define (error* msg args)
+  (if (procedure? *reset*)
+      (let ([p (current-error-port)])
+        (display msg p) (newline p)
+        (for-each (lambda (arg) (write arg p) (newline p)) args)
+        (*reset* #f))
+      (apply error (cons msg args)))) 
+     
 (define (run-tests)
   (define start (current-jiffy))
   (display "Running tests ...") (newline)
@@ -1547,20 +1578,22 @@
   (display " ms.") (newline))
 
 (define (repl-eval x)
-  (let ([xexp (transform #f x)])
+  (letcc catch
-    (when *verbose* (display "TRANSFORM =>") (newline) (write xexp) (newline))
+    (set! *reset* catch)
-    (if (eq? (car xexp) 'define) (set-car! xexp 'set!))
+    (let ([xexp (transform #f x)])
-    (when *verbose* (display "COMPILE-TO-STRING =>") (newline))
+      (when *verbose* (display "TRANSFORM =>") (newline) (write xexp) (newline))
-    (let ([cstr (compile-to-string xexp)] [start #f])
+      (if (eq? (car xexp) 'define) (set-car! xexp 'set!))
-      (when *verbose* 
+      (when *verbose* (display "COMPILE-TO-STRING =>") (newline))
-        (display cstr) (newline)
+      (let ([cstr (compile-to-string xexp)] [start #f])
-        (display "DECODE+EXECUTE =>") (newline)
+        (when *verbose* 
-        (set! start (current-jiffy)))
+          (display cstr) (newline)
-      (let* ([thunk (decode cstr)] [res (execute thunk)])
+          (display "DECODE+EXECUTE =>") (newline)
-        (write res) (newline))
+          (set! start (current-jiffy)))
-      (when *verbose* 
+        (let* ([thunk (decode cstr)] [res (execute thunk)])
-        (display "Elapsed time: ") (write (* 1000 (/ (- (current-jiffy) start) (jiffies-per-second))))
+          (write res) (newline))
-        (display " ms.") (newline)))))
+        (when *verbose* 
+          (display "Elapsed time: ") (write (* 1000 (/ (- (current-jiffy) start) (jiffies-per-second))))
+          (display " ms.") (newline))))))
 
 (define (repl-eval-top-form x)
   (cond 

src/s.scm

@@ -1,28 +1,112 @@
 
 ;---------------------------------------------------------------------------------------------
-; Scheme library functions
+; SCHEME LIBRARY FUNCTIONS
 ;---------------------------------------------------------------------------------------------
 
-;---------------------------------------------------------------------------------------------
-; helpers
-;---------------------------------------------------------------------------------------------
-
-(define-syntax define-inline
-  (syntax-rules ()
-    [(_ (id v ...) rid expr)
-     (begin
-       (define-syntax id
-         (syntax-rules ()
-           [(_ v ...) expr] ; NB: do not use the same var twice!
-           [(_ . r) (rid . r)] ; NB: use syntax-error?
-           [_ rid]))
-       (define rid (lambda (v ...) expr)))]))
-
 
 ;---------------------------------------------------------------------------------------------
 ; Derived expression types
 ;---------------------------------------------------------------------------------------------
 
+#|
+(define-syntax let-syntax
+  (syntax-rules ()
+    [(_ ([kw init] ...))
+     (begin)]
+    [(_ ([kw init] ...) . forms)
+     ((syntax-lambda (kw ...) . forms)
+      init ...)]))
+
+(define-syntax syntax-lambda
+  (let-syntax ([org-sl syntax-lambda])
+    (syntax-rules ()
+      [(_ (v ...) form) (org-sl (v ...) form)]
+      [(_ (v ...) . forms) (org-sl (v ...) (block . forms))])))
+
+(define-syntax letrec-syntax
+  (syntax-rules ()
+    [(_ ([key trans] ...) . forms) ; non-splicing!
+     (body (define-syntax key trans) ... . forms)]))
+
+(define-syntax letrec
+  (syntax-rules ()
+    [(_ ([var init] ...) . forms)
+     (body (define var init) ... . forms)]))
+
+(define-syntax let
+  (syntax-rules ()
+    [(_ ([var init] ...) . forms)
+     ((lambda (var ...) . forms) init ...)]
+    [(_ name ([var init] ...) . forms)
+     ((letrec ((name (lambda (var ...) . forms))) name) init ...)]))
+
+(define-syntax let*
+  (syntax-rules ()
+    [(_ () . forms) 
+     (body . forms)]
+    [(_ (first . more) . forms)
+     (let (first) (let* more . forms))]))
+
+(define-syntax and
+  (syntax-rules ()
+    [(_) #t]
+    [(_ test) test]
+    [(_ test . tests) (if test (and . tests) #f)]))
+
+(define-syntax or
+  (syntax-rules ()
+    [(_) #f]
+    [(_ test) test]
+    [(_ test . tests) (let ([x test]) (if x x (or . tests)))]))
+
+(define-syntax cond
+  (syntax-rules (else =>)
+    [(_) #f]
+    [(_ (else . exps)) (begin . exps)]
+    [(_ (x) . rest) (or x (cond . rest))]
+    [(_ (x => proc) . rest) (let ([tmp x]) (cond [tmp (proc tmp)] . rest))]
+    [(_ (x . exps) . rest) (if x (begin . exps) (cond . rest))]))
+
+(define-syntax case-test
+  (syntax-rules (else) 
+    [(_ k else) #t]
+    [(_ k atoms) (memv k 'atoms)]))
+
+(define-syntax case
+  (syntax-rules ()
+    [(_ x (test . exprs) ...)
+     (let ([key x]) (cond ((case-test key test) . exprs) ...))]))
+
+(define-syntax do
+  (syntax-rules ()
+    [(_ ((var init . step) ...) ending expr ...)
+     (let loop ([var init] ...)
+       (cond ending [else expr ... (loop (begin var . step) ...)]))]))
+
+(define-syntax quasiquote
+  (syntax-rules (unquote unquote-splicing quasiquote)
+    [(_ ,x) x]
+    [(_ (,@x . y)) (append x `y)]
+    [(_ `x . d) (cons 'quasiquote (quasiquote (x) d))]
+    [(_ ,x   d) (cons 'unquote (quasiquote (x) . d))]
+    [(_ ,@x  d) (cons 'unquote-splicing (quasiquote (x) . d))]
+    [(_ (x . y) . d) (cons (quasiquote x . d) (quasiquote y . d))]
+    [(_ #(x ...) . d) (list->vector (quasiquote (x ...) . d))]
+    [(_ x . d) 'x]))
+
+(define-syntax when
+  (syntax-rules ()
+    [(_ test . rest) (if test (begin . rest))]))
+
+(define-syntax unless
+  (syntax-rules ()
+    [(_ test . rest) (if (not test) (begin . rest))]))
+
+(define-syntax case-lambda
+  (syntax-rules ()
+    [(_ [args . body] ...) (lambda* [args (lambda args . body)] ...)]))
+|#
+
 ;cond
 ;case
 ;and
@@ -319,7 +403,11 @@
     [(_ . args) (%assoc . args)]
     [_ %assoc]))
 
-(define-inline (list-copy x) %residual-list-copy (%lcat x '()))
+(define (list-copy obj)
+  (let loop ([obj obj])
+    (if (pair? obj)
+        (cons (car obj) (loop (cdr obj)))
+        obj)))
 
 ; (list-tail l i)
 ; (last-pair l)