Error traces now point within .arc files

ac.rkt

@@ -24,6 +24,7 @@
   openssl
   racket/string
   racket/random
+  syntax/stx
 
   (only-in "brackets.rkt" bracket-readtable)
 
@@ -103,17 +104,47 @@
     ([anarki-init-in-main-namespace-func anarki-init-verbose])
     (anarki-init-in-main-namespace)))
 
+
+(print-hash-table #t)
+(print-syntax-width 10000)
+
+; sread = scheme read. eventually replace by writing read
+
+(define (sread p (eof eof))
+  (parameterize ((read-accept-lang #t)
+                 (read-accept-reader #t))
+    (port-count-lines! p)
+    (let ((expr (read-syntax (object-name p) p)))
+      (if (eof-object? expr) eof expr))))
+
+(define (syn x (src #f))
+  (if (syntax? x)
+      (syn (syntax->datum x) (or src x))
+      (datum->syntax #f x (if (syntax? src) src #f))))
+
+(define (datum x)
+  (let ((s (syn x)))
+    (syntax->datum s)))
+
+(define env* (make-parameter (list)))
+
 ; compile an Arc expression into a Scheme expression,
 ; both represented as s-expressions.
 ; env is a list of lexically bound variables, which we
 ; need in order to decide whether set should create a global.
 
-(defarc (ac s env)
+(define (stx-map proc stxl)
+  (map proc (stx->list stxl)))
+
+(defarc (ac* e s env)
   (cond [(string? s) (ac-string s env)]
-        [(literal? s) (list 'quote s)]
+        [(keyword? s) s]
+        [(literal? s) (list 'quote (ac-quoted s))]
         [(eqv? s 'nil) (list 'quote 'nil)]
         [(ssyntax? s) (ac (expand-ssyntax s) env)]
         [(symbol? s) (ac-var-ref s env)]
+        [(eq? (xcar s) 'syntax) (cadr (syntax-e e))]
+        [(eq? (xcar (xcar s)) 'syntax) (stx-map ac e)]
         [(ssyntax? (xcar s)) (ac (cons (expand-ssyntax (car s)) (cdr s)) env)]
         [(eq? (xcar s) '$) (ac-$ (cadr s) env)]
         [(eq? (xcar s) 'quote) (list 'quote (ac-quoted (ac-niltree (cadr s))))]
@@ -131,8 +162,17 @@
          (ac (list 'no (cons (cadar s) (cdr s))) env)]
         [(eq? (xcar (xcar s)) 'andf) (ac-andf s env)]
         [(pair? s) (ac-call (car s) (cdr s) env)]
+        [(syntax? s) s]
         [#t (err "Bad object in expression" s)]))
 
+(defarc (ac stx (env (env*)) (ns main-namespace))
+  (parameterize ((env* env))
+    (let* ((s (syn stx))
+           (e (syntax->datum s))
+           (expr (ac* s e env)))
+      (parameterize ((current-namespace ns))
+        (namespace-syntax-introduce (syn expr stx))))))
+
 (define (ac-string s env)
   (if (ar-bflag 'atstrings)
       (if (atpos s 0)
@@ -539,16 +579,21 @@
 
 (define (ac-set1 a b1 env)
   (if (symbol? a)
-      (let ([b (ac b1 (ac-dbname! a env))])
-        (list 'let `([zz ,b])
-               (cond [(eqv? a 'nil) (err "Can't rebind nil")]
-                     [(eqv? a 't) (err "Can't rebind t")]
-                     [(lex? a env) `(set! ,a zz)]
-                     [(ac-defined-var? a) `(,(ac-global-name a) zz)]
-                     [#t `(set! ,(ac-global-name a) zz)])
-               'zz))
+      (let ((n (string->symbol (string-append " " (symbol->string a))))
+            (b (ac b1 (ac-dbname! a env))))
+        (list 'let `((,n ,b))
+               (cond ((eqv? a 'nil) (err "Can't rebind nil"))
+                     ((eqv? a 't) (err "Can't rebind t"))
+                     ((eqv? a 'true) (err "Can't rebind true"))
+                     ((eqv? a 'false) (err "Can't rebind false"))
+                     ((eqv? a 'null) (err "Can't rebind null"))
+                     ((lex? a env) `(set! ,a ,n))
+                     [(ac-defined-var? a) `(,(ac-global-name a) ,n)]
+                     (#t `(set! ,(ac-global-name a) ,n)))
+               n))
       (err "First arg to set must be a symbol" a)))
 
+
 ; given a list of Arc expressions, return a list of Scheme expressions.
 ; for compiling passed arguments.
 
@@ -610,7 +655,7 @@
 
 (define (ac-macro? fn)
   (if (symbol? fn)
-    (let ([v (and (bound? fn) (arc-eval fn))])
+    (let ([v (and (bound? fn) (bound fn))])
       (if (and v
                (ar-tagged? v)
                (eq? (ar-type v) 'mac))
@@ -936,6 +981,7 @@
         ((async-channel? x) 'channel)
         ((evt? x)           'event)
         [(keyword? x)       'keyword]
+        [(syntax? x)        'syntax]
         [#t                 (err "Type: unknown type" x)]))
 (xdef type ar-type)
 
@@ -1050,9 +1096,10 @@
 
 ; sread = scheme read. eventually replace by writing read
 
-(xdef sread (lambda (p)
-               (let ([expr (read p)])
+(xdef sdata (lambda (p (eof eof))
+               (let ((expr (read p)))
                  (if (eof-object? expr) eof expr))))
+(xdef sread sread)
 
 ; these work in PLT but not scheme48
 
@@ -1316,10 +1363,13 @@
 ;
 (define (arc-exec racket-expr)
   (eval (parameterize ([compile-allow-set!-undefined #t])
-          (compile racket-expr))))
+          (if (syntax? racket-expr)
+              (compile-syntax (namespace-syntax-introduce racket-expr))
+              (compile racket-expr)))))
 
-(define (arc-eval expr)
-  (arc-exec (ac expr '())))
+(define (arc-eval expr (env (env*)))
+  (parameterize ((env* env))
+    (arc-exec (ac expr))))
 
 (define (tle)
   (display "Arc> ")
@@ -1412,15 +1462,15 @@ Arc 3.1 documentation: https://arclanguage.github.io/ref.
   (xdef current-fn current-fn))
 
 (define (aload1 p)
-  (let ([x (read p)])
+  (let ([x (sread p)])
     (if (eof-object? x)
         (void)
         (begin
           (arc-eval x)
           (aload1 p)))))
 
 (define (atests1 p)
-  (let ([x (read p)])
+  (let ([x (sread p)])
     (if (eof-object? x)
         #t
         (begin
@@ -1479,10 +1529,10 @@ Arc 3.1 documentation: https://arclanguage.github.io/ref.
   (call-with-line-counting-input-file filename atests1))
 
 (define (acompile1 ip op)
-  (let ([x (read ip)])
+  (let ([x (sread ip)])
     (if (eof-object? x)
         #t
-        (let ([scm (ac x '())])
+        (let ([scm (ac x)])
           (arc-exec scm)
           (pretty-print scm op)
           (newline op)
@@ -1596,6 +1646,11 @@ Arc 3.1 documentation: https://arclanguage.github.io/ref.
     (namespace-variable-value (ac-global-name arcname))
     #t))
 
+(define (bound arcname)
+  (with-handlers ([exn:fail:syntax? (lambda (e) #t)]
+                  [exn:fail:contract:variable? (lambda (e) #f)])
+    (namespace-variable-value (ac-global-name arcname))))
+
 (xdef bound (lambda (x) (tnil (bound? x))))
 
 (xdef newstring make-string)

arc.arc

@@ -1557,17 +1557,17 @@ read from the stream 'str'."
      (tostring ,@body)
      ,dest))
 
-(def readstring1 (s)
+(def readstring1 (s (o data t))
 "Reads a single expression from string 's'. Returns the uninterned symbol
 stored as the global value of 'eof' if there's nothing left to read."
-  (w/instring i s (read i)))
+  (w/instring i s (read i data)))
 
-(def read ((o x (stdin)))
+(def read ((o x (stdin)) (o data t))
 "Reads a single expression from string or stream 'x'. Returns the uninterned
 symbol stored as the global value of 'eof' if there's nothing left to read."
   (if (isa x 'string)
-    (readstring1 x)
-    (sread x)))
+    (readstring1 x data)
+    ((if data sdata sread) x)))
 
 (mac fromfile (f . body)
 "Redirects standard input from the file 'f' within 'body'."
@@ -2859,10 +2859,10 @@ of 'x' by calling 'self'."
     (map (fn ((k v)) (= h.k unserialize.v))
          rep*.x)))
 
-(redef read ((o x (stdin)))
+(redef read ((o x (stdin)) (o data t))
   (if (isa x 'string)
-    (readstring1 x)
-    (unserialize:sread x)))
+    (readstring1 x data)
+    (unserialize ((if data sdata sread) x))))
 
 (def write (x (o port (stdout)))
   (swrite serialize.x port))