From 58c309cfa41ef33ea2b3de1fb1a6c659b25c9fe4 Mon Sep 17 00:00:00 2001 From: Shawn Presser Date: Tue, 29 Jan 2019 13:52:17 -0600 Subject: [PATCH] Error traces now point within .arc files --- ac.rkt | 95 +++++++++++++++++++++++++++++++++++++++++++++------------ arc.arc | 16 +++++----- 2 files changed, 83 insertions(+), 28 deletions(-) diff --git a/ac.rkt b/ac.rkt index 449897aa1..4baada88e 100644 --- a/ac.rkt +++ b/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,7 +1462,7 @@ 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 @@ -1420,7 +1470,7 @@ Arc 3.1 documentation: https://arclanguage.github.io/ref. (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) diff --git a/arc.arc b/arc.arc index 74dda71b8..a6f1e6f70 100644 --- a/arc.arc +++ b/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))