minor refactoring of the transformer

src/k.sf

@@ -259,9 +259,13 @@
 (define (add-var var val env) ; adds renamed var as <core>
   (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)))
+
 ; 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
-; a transformer (a procedure)
+; a transformer (a procedure). Appos? flag is true when the context can
+; allow xform to return a transformer; otherwise, only <core> is accepted. 
 
 (define (xform appos? sexp env)
   (cond [(id? sexp) 
@@ -273,61 +277,65 @@
                   (xform appos? (hval sexp env) env)]
                  [else hval]))]
         [(not (pair? sexp))
-         (xform-quote sexp env)]
+         (xform-quote (list sexp) env)]
         [else 
          (let* ([head (car sexp)] [tail (cdr sexp)] [hval (xform #t head env)])
            (case hval
              [(syntax)        (car tail)] ; internal use only
-             [(quote)         (xform-quote (car tail) env)]
+             [(quote)         (xform-quote         tail env)]
-             [(set!)          (xform-set! (car tail) (cadr tail) env)]
+             [(set!)          (xform-set!          tail env)]
-             [(set&)          (xform-set& tail env)]
+             [(set&)          (xform-set&          tail env)]
-             [(begin)         (xform-begin tail env)]
+             [(begin)         (xform-begin         tail env)]
-             [(if)            (xform-if tail env)]
+             [(if)            (xform-if            tail env)]
-             [(lambda)        (xform-lambda tail env)]
+             [(lambda)        (xform-lambda        tail env)]
-             [(lambda*)       (xform-lambda* tail env)]
+             [(lambda*)       (xform-lambda*       tail env)]
-             [(letcc)         (xform-letcc tail env)]
+             [(letcc)         (xform-letcc         tail env)]
-             [(withcc)        (xform-withcc tail env)]
+             [(withcc)        (xform-withcc        tail env)]
-             [(body)          (xform-body tail env)]
+             [(body)          (xform-body          tail env)]
-             [(define)        (xform-define (car tail) (cadr tail) env)]
+             [(define)        (xform-define        tail env)]
-             [(define-syntax) (xform-define-syntax (car tail) (cadr tail) env)]
+             [(define-syntax) (xform-define-syntax tail env)]
              [else            (if (integrable? hval)
                                   (xform-integrable hval tail env)
                                   (if (procedure? hval)
                                       (xform appos? (hval sexp env) env)
                                       (xform-call hval tail env)))]))]))
 
-(define (xform-quote sexp env)
-  (list 'quote 
-    (let conv ([sexp sexp])
-      (cond [(id? sexp) (id->sym sexp)]
-            [(pair? sexp) (cons (conv (car sexp)) (conv (cdr sexp)))]
-            [(vector? sexp) (list->vector (map conv (vector->list sexp)))]
-            [else sexp]))))
-
 (define (xform-ref id env)
   (let ([den (env id)])
     (cond [(symbol? den) (list 'ref den)]
           [else (binding-val den)])))
 
-(define (xform-set! id exp env)
+(define (xform-quote tail env)
-  (let ([den (env id)] [xexp (xform #f exp env)])
+  (if (list1? tail)
-    (cond [(symbol? den) (list 'set! den xexp)]
+      (list 'quote 
-          [(binding-special? den) (binding-set-val! den xexp) '(begin)]
+        (let conv ([sexp (car tail)])
-          [else (let ([val (binding-val den)])
+          (cond [(id? sexp) (id->sym sexp)]
-                  (if (eq? (car val) 'ref)
+                [(pair? sexp) (cons (conv (car sexp)) (conv (cdr sexp)))]
-                      (list 'set! (cadr val) xexp)
+                [(vector? sexp) (list->vector (map conv (vector->list sexp)))]
-                      (error 'transform "set! to non-identifier form")))])))
+                [else sexp])))
+      (x-error "improper quote form" (cons 'quote tail))))
+
+(define (xform-set! tail env)
+  (if (and (list2? tail) (id? (car tail)))
+      (let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)])
+        (cond [(symbol? den) (list 'set! den xexp)]
+              [(binding-special? den) (binding-set-val! den xexp) '(begin)]
+              [else (let ([val (binding-val den)])
+                      (if (eq? (car val) 'ref)
+                          (list 'set! (cadr val) xexp)
+                          (x-error "set! to non-identifier form")))]))
+      (x-error "improper set! form" (cons 'set! tail))))
 
 (define (xform-set& tail env)
   (if (list1? tail)
       (let ([den (env (car tail))])      
         (cond [(symbol? den) (list 'set& den)]
-              [(binding-special? den) (error 'transform "set& of a non-variable")]
+              [(binding-special? den) (x-error "set& of a non-variable")]
               [else (let ([val (binding-val den)])
                       (if (eq? (car val) 'ref)
                           (list 'set& (cadr val))
-                          (error 'transform "set& of a non-variable")))]))
+                          (x-error "set& of a non-variable")))]))
-      (error 'transform "improper set& form")))
+      (x-error "improper set& form" (cons 'set& tail))))
 
 (define (xform-begin tail env)
   (if (list? tail)
@@ -335,7 +343,7 @@
         (if (and (pair? xexps) (null? (cdr xexps)))
             (car xexps) ; (begin x) => x
             (cons 'begin xexps)))
-      (error 'transform "improper begin form")))
+      (x-error "improper begin form" (cons 'begin! tail))))
 
 (define (xform-if tail env)
   (if (list? tail)
@@ -343,8 +351,8 @@
         (case (length xexps)
           [(2) (cons 'if (append xexps '((begin))))]
           [(3) (cons 'if xexps)]
-          [else (error 'transform "malformed if form")]))
+          [else (x-error "malformed if form" (cons 'if tail))]))
-      (error 'transform "improper if form")))
+      (x-error "improper if form" (cons 'if tail))))
 
 (define (xform-call xexp tail env)
   (if (list? tail)
@@ -352,7 +360,7 @@
         (if (and (null? xexps) (eq? (car xexp) 'lambda) (null? (cadr xexp)))
             (caddr xexp) ; ((let () x)) => x
             (pair* 'call xexp xexps)))
-      (error 'transform "improper application")))
+      (x-error "improper application" (cons xexp tail))))
 
 (define (integrable-argc-match? igt n)
   (case igt
@@ -380,7 +388,7 @@
                       [ienv (add-var var nvar ienv)])
                 (list 'lambda (append (reverse ipars) nvar)
                   (xform-body (cdr tail) ienv)))]))
-      (error 'transform "improper lambda body" tail)))
+      (x-error "improper lambda body" (cons 'lambda tail))))
 
 (define (xform-lambda* tail env)
   (if (list? tail)
@@ -391,22 +399,22 @@
                               (idslist? (car aexp))))
                      (list (normalize-arity (car aexp))
                            (xform #f (cadr aexp) env))
-                     (error 'transform "improper lambda* clause")))
+                     (x-error "improper lambda* clause" aexp)))
               tail))
-      (error 'transform "improper lambda* form")))
+      (x-error "improper lambda* form" (cons 'lambda* tail))))
 
 (define (xform-letcc tail env)
   (if (and (list2+? tail) (id? (car tail)))
       (let* ([var (car tail)] [nvar (gensym (id->sym var))])
         (list 'letcc nvar 
           (xform-body (cdr tail) (add-var var nvar env))))
-      (error 'transform "improper letcc form")))
+      (x-error "improper letcc form" (cons 'letcc tail))))
 
 (define (xform-withcc tail env)
   (if (list2+? tail)
       (list 'withcc (xform #f (car tail) env)
         (xform-body (cdr tail) env))
-      (error 'transform "improper withcc form")))
+      (x-error "improper withcc form" (cons 'withcc tail))))
 
 (define (xform-body tail env)
   (if (null? tail)
@@ -446,27 +454,27 @@
                    (map (lambda (lid) '(begin)) lids))))]
           [(symbol? (car nids)) ; define
            (loop (cdr ids) (cdr inits) (cdr nids)
-             (cons (xform-set! (car ids) (car inits) env) sets)
+             (cons (xform-set! (list (car ids) (car inits)) env) sets)
              (cons (car nids) lids))]
           [else ; define-syntax
            (binding-set-val! (env (car ids)) (xform #t (car inits) env))
            (loop (cdr ids) (cdr inits) (cdr nids) sets lids)])))
 
-(define (xform-define id exp env) ; top-level only
+(define (xform-define tail env) ; top-level only
-  (if (id? id)
+  (if (and (list2? tail) (id? (car tail)))
-      (list 'define (id->sym id) (xform #f exp env))
+      (list 'define (id->sym (car tail)) (xform #f (cadr tail) env))
-      (error 'transform "define of non-identifier form")))
+      (x-error "improper define form" (cons 'define tail))))
 
-(define (xform-define-syntax id exp env) ; top-level only
+(define (xform-define-syntax tail env) ; top-level only
-  (if (id? id)
+  (if (and (list2? tail) (id? (car tail)))
-      (list 'define-syntax (id->sym id) (xform #t exp env))
+      (list 'define-syntax (id->sym (car tail)) (xform #t (cadr tail) env))
-      (error 'transform "define-syntax of non-identifier form")))
+      (x-error "improper define-syntax form" (cons 'define-syntax tail))))
 
 
 ; ellipsis denotation is used for comparisons only
 
 (define denotation-of-default-ellipsis 
-  (make-binding '... (lambda (sexp env) (error '... sexp))))
+  (make-binding '... (lambda (sexp env) (x-error "improper use of ..." sexp))))
 
 (define *transformers* 
   (list
@@ -622,7 +630,7 @@
 
   (lambda (use use-env)
     (let loop ([rules rules])
-      (if (null? rules) (error 'transform "invalid syntax" use))
+      (if (null? rules) (x-error "invalid syntax" use))
       (let* ([rule (car rules)] [pat (car rule)] [tmpl (cadr rule)])
         (cond [(match-pattern pat use use-env) =>
                (lambda (bindings) (expand-template pat tmpl bindings))]
@@ -772,11 +780,13 @@
 (define-syntax index-global unbox)
 (define-syntax index-set-global! set-box!)
 
-
 ;---------------------------------------------------------------------------------------------
 ; String representation of S-expressions and code arguments
 ;---------------------------------------------------------------------------------------------
 
+(define (c-error msg . args)
+  (apply error (cons (string-append "compiler: " msg) args)))
+
 (define (write-serialized-char x port)
   (cond [(or (char=? x #\%) (char=? x #\") (char=? x #\\) (char<? x #\space) (char>? x #\~))
          (write-char #\% port)
@@ -831,7 +841,7 @@
            (write-serialized-size (string-length x) port)
            (do ([i 0 (fx+ i 1)]) [(fx=? i (string-length x))]
              (write-serialized-char (string-ref x i) port)))]
-        [else (error 'encode-sexp "cannot encode literal: ~s" x)]))
+        [else (c-error "cannot encode literal: ~s" x)]))
 
 (define (write-serialized-arg arg port)
   (if (and (number? arg) (exact? arg) (fx<=? 0 arg) (fx<=? arg 9))
@@ -1152,7 +1162,7 @@
                (write-char #\, port))
              (write-string igc0 port)
              (write-serialized-arg (length args) port)]
-            [else (error 'codegen "NYI: unsupported integrable type" igty)]))
+            [else (c-error "unsupported integrable type" igty)]))
        (when k (write-char #\] port) (write-serialized-arg k port))]
       [call (exp . args)
        (cond [(and (eq? (car exp) 'lambda) (list? (cadr exp))