Error traces now point within .arc files

ac.rkt

@@ -24,6 +24,7 @@
   openssl
   racket/string
   racket/random
+
   racket/struct
 
   (only-in "brackets.rkt" bracket-readtable)
@@ -104,19 +105,26 @@
     ([anarki-init-in-main-namespace-func anarki-init-verbose])
     (anarki-init-in-main-namespace)))
 
+
 (struct ar-tagged (type rep) #:prefab)
 
 ; 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))))]
@@ -135,8 +143,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)
@@ -548,6 +565,7 @@
 
 (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")]
@@ -557,8 +575,10 @@
                      [(ac-defined-var? a) `(,(ac-global-name a) zz)]
                      [#t `(set! ,(ac-global-name a) zz)])
                'zz))
+
       (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.
 
@@ -666,7 +686,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))
@@ -990,6 +1010,7 @@
         ((async-channel? x) 'channel)
         ((evt? x)           'event)
         [(keyword? x)       'keyword]
+        [(syntax? x)        'syntax]
         [#t                 (err "Type: unknown type" x)]))
 (xdef type ar-type)
 
@@ -1104,10 +1125,12 @@
 
 ; sread = scheme read. eventually replace by writing read
 
+
 (xdef sread (lambda (p)
                (let ([expr (read p)])
                  expr)))
 
+
 ; these work in PLT but not scheme48
 
 (define char->ascii char->integer)
@@ -1370,7 +1393,10 @@
 ;
 (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 . args)
   (if (null? args)
@@ -1483,15 +1509,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
@@ -1549,10 +1575,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)
@@ -1672,6 +1698,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

@@ -1562,17 +1562,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'."
@@ -2867,10 +2867,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))