From: Doug Evans Date: Thu, 6 Aug 2009 16:40:44 +0000 (+0000) Subject: Track source location better, for better error messages. X-Git-Url: https://sourceware.org/git/?a=commitdiff_plain;h=59caadc44834d647638f12d93992cd79385bd1b8;p=cgen.git Track source location better, for better error messages. * pmacros.scm (-pmacro-eval): Delete, unused. (pmacro-expand, -pmacro-expand): New arg `loc', all callers updated. (-pmacro-expand-expr-list, -smacro-apply): Ditto. (scan-list, scan): Ditto. (-pmacro-builtin-pmacro, -pmacro-builtin-let, -pmacro-builtin-if, -pmacro-builtin-case, -pmacro-builtin-cond, -pmacro-builtin-begin, -pmacro-builtin-andif, -pmacro-builtin-orif): Ditto. (scan-list1): New function. (-pmacro-build-lambda): New arg `loc', all callers updated. Rewrite. * read.scm (): New member `location'. (-reader-lookup-command): Renamed from reader-lookup-command, all callers updated. (reader-error): Rewrite to produce better source location info. (current-reader-location): New function. (-reader-process-expanded-1!): Renamed from -reader-process-expanded-1. All callers updated. Record source location of expression. (reader-process-expanded!): Renamed from reader-process-expanded. All callers updated. (-reader-process!): Renamed from reader-process. New arg `loc'. All callers updated. Record source location of define-pmacro. * utils-cgen.scm (): New class. (single-location): New (pseudo) class. (pretty-print-single-location, pretty-print-location): New functions. (location-top, location-push-single, location-push): New functions. (unspecified-location, current-input-location): New functions. (location-property): New object property. (location-property-set!): New function. (): Renamed from . New member `location'. All uses updated. * testsuite/location-1.test: New testcase. * testsuite/run-tests.sh: Fix fail count handling. * testsuite/test-utils.sh.in (run_cgen): New option `-f'. Allow tests to expect cgen to fail. * pmacros.scm (*): Use "pmacro" instead of "macro" more consistently. * read.scm (-cmd-include): Renamed from include. All callers updated. (-cmd-if): Renamed from cmd-if. All callers updated. Use reader-process-expanded! on then/else clauses instead of eval1. --- diff --git a/ChangeLog b/ChangeLog index 1584d9b..08fd534 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,46 @@ +2009-08-05 Doug Evans + + Track source location better, for better error messages. + * pmacros.scm (-pmacro-eval): Delete, unused. + (pmacro-expand, -pmacro-expand): New arg `loc', all callers updated. + (-pmacro-expand-expr-list, -smacro-apply): Ditto. + (scan-list, scan): Ditto. + (-pmacro-builtin-pmacro, -pmacro-builtin-let, -pmacro-builtin-if, + -pmacro-builtin-case, -pmacro-builtin-cond, -pmacro-builtin-begin, + -pmacro-builtin-andif, -pmacro-builtin-orif): Ditto. + (scan-list1): New function. + (-pmacro-build-lambda): New arg `loc', all callers updated. Rewrite. + * read.scm (): New member `location'. + (-reader-lookup-command): Renamed from reader-lookup-command, + all callers updated. + (reader-error): Rewrite to produce better source location info. + (current-reader-location): New function. + (-reader-process-expanded-1!): Renamed from -reader-process-expanded-1. + All callers updated. Record source location of expression. + (reader-process-expanded!): Renamed from reader-process-expanded. + All callers updated. + (-reader-process!): Renamed from reader-process. New arg `loc'. + All callers updated. Record source location of define-pmacro. + * utils-cgen.scm (): New class. + (single-location): New (pseudo) class. + (pretty-print-single-location, pretty-print-location): New functions. + (location-top, location-push-single, location-push): New functions. + (unspecified-location, current-input-location): New functions. + (location-property): New object property. + (location-property-set!): New function. + (): Renamed from . New member `location'. + All uses updated. + * testsuite/location-1.test: New testcase. + * testsuite/run-tests.sh: Fix fail count handling. + * testsuite/test-utils.sh.in (run_cgen): New option `-f'. Allow tests + to expect cgen to fail. + + * pmacros.scm (*): Use "pmacro" instead of "macro" more consistently. + + * read.scm (-cmd-include): Renamed from include. All callers updated. + (-cmd-if): Renamed from cmd-if. All callers updated. + Use reader-process-expanded! on then/else clauses instead of eval1. + 2009-07-22 Doug Evans * modes.scm (TI,OI): New modes. diff --git a/ifield.scm b/ifield.scm index 76314d1..14507eb 100644 --- a/ifield.scm +++ b/ifield.scm @@ -23,7 +23,7 @@ (define (class-make ' - '() + '() '( ; The mode the raw value is to be interpreted in. mode diff --git a/insn.scm b/insn.scm index 108d3d4..a034248 100644 --- a/insn.scm +++ b/insn.scm @@ -7,7 +7,7 @@ (define (class-make ' - '() + '() '( ; Used to explicitly specify mnemonic, now it's computed from ; syntax string. ??? Might be useful as an override someday. @@ -437,6 +437,7 @@ ; Read an instruction description. ; This is the main routine for analyzing instructions in the .cpu file. +; This is also used to create virtual insns by apps like simulators. ; ERRTXT is prepended to error messages to provide context. ; ARG-LIST is an associative list of field name and field value. ; -insn-parse is invoked to create the object. @@ -950,7 +951,7 @@ Define an instruction, all arguments specified. *UNSPECIFIED* ) -; Called before a . cpu file is read in to install any builtins. +; Called before a .cpu file is read in to install any builtins. (define (insn-builtin!) ; Standard insn attributes. diff --git a/mach.scm b/mach.scm index 3f0c3d6..f3b5e95 100644 --- a/mach.scm +++ b/mach.scm @@ -120,7 +120,7 @@ lowest-obj) ) -;; Table of objects with two access styles: +;; Table of objects with two access styles: ;; hash lookup, ordered list. ;; The main table is the hash table, the list is lazily created and cached. ;; The table is recorded as (hash-table . list). @@ -128,7 +128,7 @@ ;; Each entry in the hash table is a list, multiple objects can have the same ;; key (e.g. insns from different isas can have the same name). ;; -;; This relies on the ordinal element of objects to build the +;; This relies on the ordinal element of objects to build the ;; ordered list. (define (-make-ident-object-table hash-size) diff --git a/minsn.scm b/minsn.scm index 2d69a83..17ad60e 100644 --- a/minsn.scm +++ b/minsn.scm @@ -24,7 +24,7 @@ (define (class-make ' - '() + '() '( ; syntax of the macro syntax diff --git a/operand.scm b/operand.scm index e14686c..d56ffce 100644 --- a/operand.scm +++ b/operand.scm @@ -17,7 +17,7 @@ (define (class-make ' - '() + '() '( ; Name as used in semantic code. ; Generally this is the same as NAME. It is changed by the diff --git a/pmacros.scm b/pmacros.scm index d1da3a7..6dbc9d8 100644 --- a/pmacros.scm +++ b/pmacros.scm @@ -14,8 +14,9 @@ ; Required routines: ; make-hash-table, hashq-ref, hashq-set! ; string-append, symbol-append, map, apply, number?, number->string, -; eval, num-args-ok?, *UNSPECIFIED*. +; eval, reader-process-expanded!, num-args-ok?, *UNSPECIFIED*. ; `num-args-ok?' and `*UNSPECIFIED*' are defined in cgen's utils.scm. +; reader-process-expanded! is defined in cgen's read.scm. ; The convention we use says `-' begins "local" objects. ; At some point this might also use the Guile module system. @@ -24,22 +25,26 @@ ; ; pmacro-init! - initialize the pmacro system ; -; define-pmacro - define a symbolic or procedural macro +; define-pmacro - define a symbolic or procedural pmacro ; ; (define-pmacro symbol ["comment"] expansion) ; (define-pmacro (symbol [args]) ["comment"] (expansion)) ; ; ARGS is a list of `symbol' or `(symbol default-value)' elements. ; -; pmacro-expand - expand all macros in an expression +; pmacro-expand - expand all pmacros in an expression ; -; (pmacro-expand expression) +; (pmacro-expand expression loc) +; +; pmacro-debug - expand all pmacros in an expression, but don't process .eval +; +; (pmacro-debug expression) ; ; pmacro-trace - same as pmacro-expand, but print debugging messages ; ; (pmacro-trace expression) -; Builtin macros: +; Builtin pmacros: ; ; (.sym symbol1 symbol2 ...) - symbolstr-append ; (.str string1 string2 ...) - stringsym-append @@ -52,7 +57,7 @@ ; (.map pmacro arg1 . arg-rest) ; (.for-each pmacro arg1 . arg-rest) ; (.eval expr) - process expr immediately -; (.apply macro-name arg) +; (.apply pmacro-name arg) ; (.pmacro (arg-list) expansion) - akin go lambda in Scheme ; (.let (var-list) expr1 . expr-rest) - akin to let in Scheme ; (.if expr then [else]) @@ -101,14 +106,14 @@ ; .sym and .str convert numbers to symbols/strings as necessary (base 10). ; ; .pmacro is for constructing pmacros on-the-fly, like lambda, and is currently -; only valid as arguments to other macros or assigned to a local in a {.let}. +; only valid as arguments to other pmacros or assigned to a local in a {.let}. ; ; ??? Methinks .foo isn't a valid R5RS symbol. May need to change ; to something else. -; True if doing macro expansion via pmacro-debug or pmacro-trace. +; True if doing pmacro expansion via pmacro-debug or pmacro-trace. (define -pmacro-debug? #f) -; True if doing macro expansion via pmacro-trace. +; True if doing pmacro expansion via pmacro-trace. (define -pmacro-trace? #f) ; The pmacro table. @@ -199,20 +204,13 @@ (-pmacro-expected-non-negative-integer op n)) ) -; Utility to evaluate pmacro args. -; ??? Currently unused, keep for now. - -(define (-pmacro-eval expr) - (eval1 expr) -) - -; Expand a list of expressions, in order +; Expand a list of expressions, in order. ; The result is the value of the last one. -(define (-pmacro-expand-expr-list exprs env) +(define (-pmacro-expand-expr-list exprs env loc) (let ((result nil)) (for-each (lambda (expr) - (set! result (-pmacro-expand expr env))) + (set! result (-pmacro-expand expr env loc))) exprs) result) ) @@ -292,14 +290,15 @@ ; Invoke a syntactic-form pmacro. ; ENV is handed down from -pmacro-expand. -(define (-smacro-apply macro args env) +(define (-smacro-apply macro args env loc) (apply (-pmacro-transformer macro) - (cons env (-pmacro-process-args macro args))) + (cons loc (cons env (-pmacro-process-args macro args)))) ) -; Expand expression EXP using ENV, an alist of variable assignments. +;; Expand expression EXP using ENV, an alist of variable assignments. +;; LOC is the location stack thus far. -(define (-pmacro-expand exp env) +(define (-pmacro-expand exp env loc) (define cep (current-error-port)) @@ -312,18 +311,18 @@ (cdr val) ; cdr is value of (name . value) pair (let ((val (-pmacro-lookup sym))) (if val - ; Symbol is a macro. - ; If this is a procedural macro, let caller perform expansion. - ; Otherwise, return the macro's value. + ; Symbol is a pmacro. + ; If this is a procedural pmacro, let caller perform expansion. + ; Otherwise, return the pmacro's value. (if (procedure? (-pmacro-transformer val)) val (-pmacro-transformer val)) ; Return symbol unchanged. sym))))) - ; See if (car exp) is a macro. - ; Return macro or #f. - (define (check-macro exp) + ; See if (car exp) is a pmacro. + ; Return pmacro or #f. + (define (check-pmacro exp) (if -pmacro-trace? (begin (display "macro? " cep) @@ -331,30 +330,64 @@ (newline cep))) (and (-pmacro? (car exp)) (car exp))) - ;; Scan each element in EXP and see if the result is a macro invocation. - (define (scan-list exp) + ;; Subroutine of scan-list to simplify it. + ;; Macro expand EXP which is known to be a non-null list. + ;; LOC is the location stack thus far. + (define (scan-list1 exp loc) ;; Check for syntactic forms. ;; They are handled differently in that we leave it to the transformer ;; routine to evaluate the arguments. (let ((sform (-smacro-lookup (car exp)))) (if sform - (-smacro-apply sform (cdr exp) env) + (-smacro-apply sform (cdr exp) env loc) ;; Not a syntactic form. ;; Evaluate all the arguments first. - (let ((scanned-exp (map scan exp))) - (let ((macro (check-macro scanned-exp))) + (let ((scanned-exp (map (lambda (e) (scan e loc)) + exp))) + (let ((macro (check-pmacro scanned-exp))) (if macro (if (procedure? (-pmacro-transformer macro)) (-pmacro-apply macro (cdr scanned-exp)) (cons (-pmacro-transformer macro) (cdr scanned-exp))) scanned-exp)))))) - ; Scan EXP, an arbitrary value. - (define (scan exp) - (let ((result (cond ((symbol? exp) (scan-symbol exp)) - ((and (list? exp) (not (null? exp))) (scan-list exp)) - ; Not a symbol or expression, return unchanged. - (else exp)))) + ;; Macro expand EXP which is known to be a non-null list. + ;; LOC is the location stack thus far. + ;; + ;; This uses scan-list1 to do the real work, this handles location tracking. + (define (scan-list exp loc) + (let ((src-props (source-properties exp)) + (new-loc loc)) + (logit 4 "scan-list exp: " exp) + (logit 4 " src-props: " src-props) + (if (not (null? src-props)) + (let ((file (assq-ref src-props 'filename)) + (line (assq-ref src-props 'line)) + (column (assq-ref src-props 'column))) + (logit 4 "new src-props: " file line) + (set! new-loc (location-push-single loc file line column #f)))) + (let ((result (scan-list1 exp new-loc))) + (if (pair? result) ;; pair? -> cheap non-null-list? + (begin + ;; Copy source location to new expression. + (if (null? (source-properties result)) + (set-source-properties! result src-props)) + (let ((loc-prop (location-property result))) + (if loc-prop + (location-property-set! result (location-push new-loc loc-prop)) + (location-property-set! result new-loc))))) + result))) + + ;; Scan EXP, an arbitrary value. + ;; LOC is the location stack thus far. + (define (scan exp loc) + (let ((result (cond ((symbol? exp) + (scan-symbol exp)) + ((pair? exp) ;; pair? -> cheap non-null-list? + (scan-list exp loc)) + ;; Not a symbol or expression, return unchanged. + (else + exp)))) ; Re-examining `result' to see if it is another pmacro invocation ; allows doing things like ((.sym a b c) arg1 arg2) ; where `abc' is a pmacro. Scheme doesn't work this way, but then @@ -367,7 +400,7 @@ (display "expand: " cep) (write exp cep) (newline cep) (display " env: " cep) (display env cep) (newline cep))) - (let ((result (scan exp))) + (let ((result (scan exp loc))) (if -pmacro-trace? (begin (display "result: " cep) (write result cep) (newline cep))) @@ -438,17 +471,27 @@ ; Build a procedure that performs a pmacro expansion. -(define (-pmacro-build-lambda prev-env params expansion) - (eval1 `(lambda ,params - (-pmacro-expand ',expansion - (-pmacro-env-make ',prev-env - ',params (list ,@params))))) +; Earlier version, doesn't work with LOC as a object, +; COS objects don't pass through eval1. +;(define (-pmacro-build-lambda prev-env params expansion) +; (eval1 `(lambda ,params +; (-pmacro-expand ',expansion +; (-pmacro-env-make ',prev-env +; ',params (list ,@params)))) +;) + +(define (-pmacro-build-lambda loc prev-env params expansion) + (lambda args + (-pmacro-expand expansion + (-pmacro-env-make prev-env params args) + loc)) ) -; ??? I'd prefer to use `define-macro', but boot-9.scm uses it and +; While using `define-macro' seems preferable, boot-9.scm uses it and ; I'd rather not risk a collision. I could of course make the association ; during parsing, maybe later. -; ??? On the other hand, calling them pmacros removes all ambiguity. +; On the other hand, calling them pmacros removes all ambiguity. +; In the end the ambiguity removal is the deciding win. ; ; The syntax is one of: ; (define-pmacro symbol expansion) @@ -462,12 +505,12 @@ ; are supported yet. There's also the difference that we treat undefined ; symbols as being themselves (i.e. "self quoting" so-to-speak). ; -; ??? We may want user-definable "syntactic" macros some day. Later. +; ??? We may want user-definable "syntactic" pmacros some day. Later. (define (define-pmacro header arg1 . arg-rest) (if (and (not (symbol? header)) (not (list? header))) - (-pmacro-error "invalid pmacro definition" header)) + (-pmacro-error "invalid pmacro header" header)) (let ((name (if (symbol? header) header (car header))) (arg-spec (if (symbol? header) #f (-pmacro-get-arg-spec (cdr header)))) (default-values (if (symbol? header) #f (-pmacro-get-default-values (cdr header)))) @@ -492,16 +535,19 @@ (-pmacro-set! name (-pmacro-make name #f #f #f expansion comment))) (-pmacro-set! name (-pmacro-make name arg-spec default-values #f - (-pmacro-build-lambda nil - arg-spec expansion) + (-pmacro-build-lambda (current-reader-location) + nil + arg-spec + expansion) comment)))) *UNSPECIFIED* ) ; Expand any pmacros in EXPR. +; LOC is the of EXPR. -(define (pmacro-expand expr) - (-pmacro-expand expr '()) +(define (pmacro-expand expr loc) + (-pmacro-expand expr '() loc) ) ; Expand any pmacros in EXPR, without processing .eval. @@ -510,12 +556,12 @@ ; FIXME: Need unwind protection. (let ((old-debug -pmacro-debug?)) (set! -pmacro-debug? #t) - (let ((result (-pmacro-expand expr '()))) + (let ((result (-pmacro-expand expr '() (unspecified-location)))) (set! -pmacro-debug? old-debug) result)) ) -; Debugging routine to trace macro expansion. +; Debugging routine to trace pmacro expansion. (define (pmacro-trace expr) ; FIXME: Need unwind protection. @@ -523,13 +569,13 @@ (old-trace -pmacro-trace?)) (set! -pmacro-debug? #t) (set! -pmacro-trace? #t) - (let ((result (-pmacro-expand expr '()))) + (let ((result (-pmacro-expand expr '() (unspecified-location)))) (set! -pmacro-debug? old-debug) (set! -pmacro-trace? old-trace) result)) ) -; Builtin macros. +; Builtin pmacros. ; (.sym symbol1 symbol2 ...) - symbol-append, auto-convert numbers @@ -671,7 +717,7 @@ (-pmacro-error "not a pmacro" pmacro)) (let ((transformer (-pmacro-transformer pmacro))) (if (not (procedure? transformer)) - (-pmacro-error "not a procedural macro" pmacro)) + (-pmacro-error "not a procedural pmacro" pmacro)) (apply map (cons transformer (cons arg1 arg-rest)))) ) @@ -682,7 +728,7 @@ (-pmacro-error "not a pmacro" pmacro)) (let ((transformer (-pmacro-transformer pmacro))) (if (not (procedure? transformer)) - (-pmacro-error "not a procedural macro" pmacro)) + (-pmacro-error "not a procedural pmacro" pmacro)) (apply for-each (cons transformer (cons arg1 arg-rest))) nil) ; need to return something the reader will accept ) @@ -690,42 +736,42 @@ ; (.eval expr) (define (-pmacro-builtin-eval expr) - ;; If we're expanding macros for debugging purposes, don't eval, + ;; If we're expanding pmacros for debugging purposes, don't eval, ;; just return unchanged. (if -pmacro-debug? (list '.eval expr) (begin - (reader-process-expanded expr) + (reader-process-expanded! expr) nil)) ;; need to return something the reader will accept ) -; (.apply macro-name arg) +; (.apply pmacro-name arg) (define (-pmacro-builtin-apply pmacro arg-list) (if (not (-pmacro? pmacro)) (-pmacro-error "not a pmacro" pmacro)) (let ((transformer (-pmacro-transformer pmacro))) (if (not (procedure? transformer)) - (-pmacro-error "not a procedural macro" pmacro)) + (-pmacro-error "not a procedural pmacro" pmacro)) (apply transformer arg-list)) ) ; (.pmacro (arg-list) expansion) -; Note: syntactic form +; NOTE: syntactic form -(define (-pmacro-builtin-pmacro env params expansion) +(define (-pmacro-builtin-pmacro loc env params expansion) ;; ??? Prohibiting improper lists seems unnecessarily restrictive here. ;; e.g. (define (foo bar . baz) ...) (if (not (list? params)) (-pmacro-error ".pmacro parameter-spec is not a list" params)) (-pmacro-make '.anonymous params #f #f - (-pmacro-build-lambda env params expansion) "") + (-pmacro-build-lambda loc env params expansion) "") ) ; (.let (var-list) expr1 . expr-rest) -; Note: syntactic form +; NOTE: syntactic form -(define (-pmacro-builtin-let env locals expr1 . expr-rest) +(define (-pmacro-builtin-let loc env locals expr1 . expr-rest) (if (not (list? locals)) (-pmacro-error ".let locals is not a list" locals)) (if (not (all-true? (map (lambda (l) @@ -735,32 +781,32 @@ locals))) (-pmacro-error "syntax error in locals list" locals)) (let* ((evald-locals (map (lambda (l) - (cons (car l) (-pmacro-expand (cadr l) env))) + (cons (car l) (-pmacro-expand (cadr l) env loc))) locals)) (new-env (append! evald-locals env))) - (-pmacro-expand-expr-list (cons expr1 expr-rest) new-env)) + (-pmacro-expand-expr-list (cons expr1 expr-rest) new-env loc)) ) ; (.if expr then [else]) -; Note: syntactic form +; NOTE: syntactic form -(define (-pmacro-builtin-if env expr then-clause . else-clause) +(define (-pmacro-builtin-if loc env expr then-clause . else-clause) (case (length else-clause) - ((0) (if (-pmacro-expand expr env) - (-pmacro-expand then-clause env) + ((0) (if (-pmacro-expand expr env loc) + (-pmacro-expand then-clause env loc) nil)) - ((1) (if (-pmacro-expand expr env) - (-pmacro-expand then-clause env) - (-pmacro-expand (car else-clause) env))) + ((1) (if (-pmacro-expand expr env loc) + (-pmacro-expand then-clause env loc) + (-pmacro-expand (car else-clause) env loc))) (else (-pmacro-error "too many elements in else-clause, expecting 0 or 1" else-clause))) ) ; (.case expr ((case-list1) stmt) [case-expr-stmt-list] [(else stmt)]) -; Note: syntactic form -; Note: this uses "member" for case comparison (Scheme uses memq I think) +; NOTE: syntactic form +; NOTE: this uses "member" for case comparison (Scheme uses memq I think) -(define (-pmacro-builtin-case env expr case1 . rest) - (let ((evald-expr (-pmacro-expand expr env))) +(define (-pmacro-builtin-case loc env expr case1 . rest) + (let ((evald-expr (-pmacro-expand expr env loc))) (let loop ((cases (cons case1 rest))) (if (null? cases) nil @@ -773,34 +819,34 @@ (not (list? (caar cases)))) (-pmacro-error "case must be \"else\" or list of choices" (caar cases))) (cond ((eq? (caar cases) 'else) - (-pmacro-expand-expr-list (cdar cases) env)) + (-pmacro-expand-expr-list (cdar cases) env loc)) ((member evald-expr (caar cases)) - (-pmacro-expand-expr-list (cdar cases) env)) + (-pmacro-expand-expr-list (cdar cases) env loc)) (else (loop (cdr cases)))))))) ) ; (.cond (expr stmt) [(cond-expr-stmt-list)] [(else stmt)]) -; Note: syntactic form +; NOTE: syntactic form -(define (-pmacro-builtin-cond env expr1 . rest) +(define (-pmacro-builtin-cond loc env expr1 . rest) (let loop ((exprs (cons expr1 rest))) (cond ((null? exprs) nil) ((eq? (car exprs) 'else) - (-pmacro-expand-expr-list (cdar exprs) env)) + (-pmacro-expand-expr-list (cdar exprs) env loc)) (else - (let ((evald-expr (-pmacro-expand (caar exprs) env))) + (let ((evald-expr (-pmacro-expand (caar exprs) env loc))) (if evald-expr - (-pmacro-expand-expr-list (cdar exprs) env) + (-pmacro-expand-expr-list (cdar exprs) env loc) (loop (cdr exprs))))))) ) ; (.begin . stmt-list) -; Note: syntactic form +; NOTE: syntactic form -(define (-pmacro-builtin-begin env . rest) - (-pmacro-expand-expr-list rest env) +(define (-pmacro-builtin-begin loc env . rest) + (-pmacro-expand-expr-list rest env loc) ) ; (.print . expr) @@ -879,30 +925,30 @@ ) ; (.andif . rest) -; Note: syntactic form +; NOTE: syntactic form ; Elements of EXPRS are evaluated one at a time. ; Unprocessed elements are not evaluated. -(define (-pmacro-builtin-andif env . exprs) +(define (-pmacro-builtin-andif loc env . exprs) (if (null? exprs) #t (let loop ((exprs exprs)) - (let ((evald-expr (-pmacro-expand (car exprs) env))) + (let ((evald-expr (-pmacro-expand (car exprs) env loc))) (cond ((null? (cdr exprs)) evald-expr) (evald-expr (loop (cdr exprs))) (else #f))))) ) ; (.orif . rest) -; Note: syntactic form +; NOTE: syntactic form ; Elements of EXPRS are evaluated one at a time. ; Unprocessed elements are not evaluated. -(define (-pmacro-builtin-orif env . exprs) +(define (-pmacro-builtin-orif loc env . exprs) (let loop ((exprs exprs)) (if (null? exprs) #f - (let ((evald-expr (-pmacro-expand (car exprs) env))) + (let ((evald-expr (-pmacro-expand (car exprs) env loc))) (if evald-expr evald-expr (loop (cdr exprs)))))) @@ -1151,7 +1197,7 @@ (set! -pmacro-table (make-hash-table 127)) (set! -smacro-table (make-hash-table 41)) - ; Some "predefined" macros. + ; Some "predefined" pmacros. (let ((macros ;; name arg-spec syntactic? function description @@ -1164,10 +1210,10 @@ (list '.substring '(string start end) #f -pmacro-builtin-substring "get start of a string") (list '.splice 'arg-list #f -pmacro-builtin-splice "splice lists into the outer list") (list '.iota '(count . start-incr) #f -pmacro-builtin-iota "iota number generator") - (list '.map '(pmacro list1 . rest) #f -pmacro-builtin-map "map a macro over a list of arguments") - (list '.for-each '(pmacro list1 . rest) #f -pmacro-builtin-for-each "execute a macro over a list of arguments") + (list '.map '(pmacro list1 . rest) #f -pmacro-builtin-map "map a pmacro over a list of arguments") + (list '.for-each '(pmacro list1 . rest) #f -pmacro-builtin-for-each "execute a pmacro over a list of arguments") (list '.eval '(expr) #f -pmacro-builtin-eval "process expr immediately") - (list '.apply '(macro arg-list) #f -pmacro-builtin-apply "apply a macro to a list of arguments") + (list '.apply '(pmacro arg-list) #f -pmacro-builtin-apply "apply a pmacro to a list of arguments") (list '.pmacro '(params expansion) #t -pmacro-builtin-pmacro "create a pmacro on-the-fly") (list '.let '(locals expr1 . rest) #t -pmacro-builtin-let "create a binding context") (list '.if '(expr then . else) #t -pmacro-builtin-if "if expr is true, process then, else else") diff --git a/read.scm b/read.scm index 35c2b15..0b17ca2 100644 --- a/read.scm +++ b/read.scm @@ -213,7 +213,7 @@ ) ; A pair of two lists: machs to keep, machs to drop. -; Keep all machs, drop none. +; The default is "keep all machs", "drop none". (define -keep-all-machs '((all))) @@ -245,14 +245,21 @@ ; (e.g. define-insn, etc.). ; Each entry is (name . command-object). (cons 'commands nil) + + ; The current source location. + ; This is recorded here by the higher level reader and is + ; fetched by commands as necessary. + 'location ) nil) ) ; Accessors. -(define-getters reader (keep-mach keep-isa current-cpu commands)) -(define-setters reader (keep-mach keep-isa current-cpu commands)) +(define-getters reader + (keep-mach keep-isa current-cpu commands location)) +(define-setters reader + (keep-mach keep-isa current-cpu commands location)) (define (reader-add-command! name comment attrs arg-spec handler) (reader-set-commands! CURRENT-READER @@ -262,7 +269,7 @@ (reader-commands CURRENT-READER))) ) -(define (reader-lookup-command name) +(define (-reader-lookup-command name) (assq-ref (reader-commands CURRENT-READER) name) ) @@ -270,19 +277,37 @@ (define CURRENT-READER #f) -; Signal an error while reading a .cpu file. +; Return the current source location in readable form. +; FIXME: Currently unused, keep for reference for awhile. -(define (reader-error msg expr help-text) - (let ((errmsg - (string-append (or (port-filename (current-input-port)) +(define (-readable-current-location) + (let ((loc (current-reader-location))) + (if loc + (pretty-print-location loc) + ;; Blech, we don't have a current reader location. That's odd. + ;; Fall back to the current input port's location. + (string-append (or (port-filename (current-input-port)) "") ":" (number->string (port-line (current-input-port))) - ": " - msg ":"))) - (error (string-append errmsg "\n" help-text) - expr)) +) + +; Signal an error while reading a .cpu file. + +(define (reader-error msg expr help-text) + (let* ((loc (current-reader-location)) + (top-sloc (location-top loc)) + (errmsg + (string-append (pretty-print-single-location top-sloc) + ": " + msg + ":\n" + (if (string=? help-text "") + "" + (string-append help-text "\n"))))) + (error (simple-format #f "While reading description:\n~A ~A\nReference chain:\n~A" + errmsg expr (pretty-print-location loc)))) ) ; Signal a parse error while reading a .cpu file. @@ -297,11 +322,22 @@ (reader-error (string-append errtxt ": " message ":") args ""))) ) +; Return the current source location. + +(define (current-reader-location) + (reader-location CURRENT-READER) +) + ; Process a macro-expanded entry. -(define (-reader-process-expanded-1 entry) +(define (-reader-process-expanded-1! entry) (logit 4 (with-output-to-string (lambda () (pretty-print entry)))) - (let ((command (reader-lookup-command (car entry)))) + + ;; Set the current source location for better diagnostics. + ;; Access with current-reader-location. + (reader-set-location! CURRENT-READER (location-property entry)) + + (let ((command (-reader-lookup-command (car entry)))) (if command (let* ((handler (command-handler command)) (arg-spec (command-arg-spec command)) @@ -326,12 +362,23 @@ (command-help command)) (apply handler (cdr entry))))) (reader-error "unknown entry type" entry ""))) + *UNSPECIFIED* ) ;; Process 1 or more macro-expanded entries. +;; ENTRY is expected to have a location-property object property. + +;; NOTE: This is "public" so the .eval pmacro can use it. +;; This is also used by -cmd-if. + +(define (reader-process-expanded! entry) + (if (and (verbose? 4) + (pair? entry)) + (let ((loc (location-property entry))) + (logit 4 "reader-process-expanded!: " (source-properties entry)) + (logit 4 " loc: " (pretty-print-location loc)))) -(define (reader-process-expanded entry) ;; () is used to indicate a no-op (cond ((null? entry) #f) ;; nothing to do @@ -340,23 +387,31 @@ ;; Scheme of course). ;; Recurse in case there are nested begins. ((eq? (car entry) 'begin) - (for-each reader-process-expanded + (for-each reader-process-expanded! (cdr entry))) (else - (-reader-process-expanded-1 entry))) + (-reader-process-expanded-1! entry))) + + *UNSPECIFIED* ) ; Process file entry ENTRY. +; LOC is a object for ENTRY. -(define (reader-process entry) +(define (-reader-process! entry loc) (if (not (form? entry)) (reader-error "improperly formed entry" entry "")) ; First do macro expansion, but not if define-pmacro of course. + ; ??? Singling out define-pmacro this way seems a bit odd. The way to look + ; at it, I guess, is to think of define-pmacro as the only current + ; "syntactic" command (it doesn't pre-evaluate its arguments). (let ((expansion (if (eq? (car entry) 'define-pmacro) - entry - (pmacro-expand entry)))) - (reader-process-expanded expansion)) + (begin (location-property-set! entry loc) entry) + (pmacro-expand entry loc)))) + (reader-process-expanded! expansion)) + + *UNSPECIFIED* ) ; Read in and process FILE. @@ -371,12 +426,17 @@ (if (eof-object? entry) #t ; done (begin - (reader-process entry) + ;; ??? The location we pass here isn't ideal. + ;; Ideally we'd pass the start location of the + ;; expression, instead we currently pass the end + ;; location (it's easier). + (-reader-process! entry (current-input-location #t)) (loop (read))))))) ) - (with-input-from-file file readit) - *UNSPECIFIED*) + (with-input-from-file file readit)) + + *UNSPECIFIED* ) ; Cpu data is recorded in an object of class . @@ -700,12 +760,10 @@ (reader-add-command! 'include "Include a file.\n" - nil '(file) include - ) + nil '(file) -cmd-include) (reader-add-command! 'if "(if test then . else)\n" - nil '(test then . else) cmd-if - ) + nil '(test then . else) -cmd-if) ; Rather than add cgen-internal specific stuff to pmacros.scm, we create ; the pmacro commands here. @@ -789,7 +847,7 @@ Define a preprocessor-style macro. ; .cpu file include mechanism -(define (include file) +(define (-cmd-include file) (logit 1 "Including file " (string-append arch-path "/" file) " ...\n") (reader-read-file! (string-append arch-path "/" file)) (logit 2 "Resuming previous file ...\n") @@ -799,33 +857,34 @@ Define a preprocessor-style macro. ; This is a work-in-progress. Its presence in the description file is ok, ; but the implementation will need to evolve. -(define (cmd-if test then . else) +(define (-cmd-if test then . else) (if (> (length else) 1) (reader-error "wrong number of arguments to `if'" (cons 'if (cons test (cons then else))) "")) + ; FIXME: Assumes TEST is a non-null-list. ; ??? rtx-eval test (if (not (memq (car test) '(keep-isa? keep-mach? application-is?))) (reader-error "only (if (keep-mach?|keep-isa?|application-is? ...) ...) are currently supported" test "")) (case (car test) ((keep-isa?) (if (keep-isa? (cadr test)) - (eval1 then) + (reader-process-expanded! then) (if (null? else) #f - (eval1 (car else))))) + (reader-process-expanded! (car else))))) ((keep-mach?) (if (keep-mach? (cadr test)) - (eval1 then) + (reader-process-expanded! then) (if (null? else) #f - (eval1 (car else))))) + (reader-process-expanded! (car else))))) ((application-is?) (if (eq? APPLICATION (cadr test)) - (eval1 then) + (reader-process-expanded! then) (if (null? else) #f - (eval1 (car else)))))) + (reader-process-expanded! (car else)))))) ) ; Top level routine for loading .cpu files. diff --git a/testsuite/location-1.test b/testsuite/location-1.test new file mode 100644 index 0000000..b172b61 --- /dev/null +++ b/testsuite/location-1.test @@ -0,0 +1,38 @@ +# location testcase #1 -*- shell-script -*- + +test=location-1 + +source ./test-utils.sh + +cpu_file=${test}.test.cpu +rm -f ${cpu_file} + +cat > ${cpu_file} <&2 ; exit 1 ; } + expect_fail=false + [ "$1" == "-f" ] && { expect_fail=true ; shift ; } + + [ $# -ne 1 ] && { echo "missing cpu_file" >&2 ; exit 1 ; } cpu_file=$1 - if ! ${GUILE} ${GUILEFLAGS} ${cgendir}/cgen-testsuite.scm \ + if ${GUILE} ${GUILEFLAGS} ${cgendir}/cgen-testsuite.scm \ -s ${cgendir} \ -b ${CGENFLAGS} \ -a ${cpu_file} \ -T ${cgen_output_file} >& ${test_output_file} then - fail "${test} run of cgen" + ${expect_fail} && { fail "${test} run of cgen expected to fail" ; } + else + ${expect_fail} || { fail "${test} run of cgen" ; } fi } diff --git a/utils-cgen.scm b/utils-cgen.scm index 03f4f54..c0da854 100644 --- a/utils-cgen.scm +++ b/utils-cgen.scm @@ -67,6 +67,114 @@ (error "vmake: unknown options:" unrecognized)))) ) +;;; Source locations are recorded as a stack, with (ideally) one extra level +;;; for each macro invocation. + +(define (class-make ' + nil + '( + ;; A list of "single-location" objects, + ;; sorted by most recent location first. + list + ) + nil)) + +(define-getters location (list)) +(define-setters location (list)) + +;;; A single source location. +;;; This is recorded as a vector for simplicity. +;;; END? is true if the location marks the end of the expression. + +(define (make-single-location file line column end?) + (vector file line column end?) +) + +(define (single-location-file sloc) (vector-ref sloc 0)) +(define (single-location-line sloc) (vector-ref sloc 1)) +(define (single-location-column sloc) (vector-ref sloc 2)) +(define (single-location-end? sloc) (vector-ref sloc 3)) + +;;; Return a single-location in a readable form. + +(define (pretty-print-single-location sloc) + (string-append (single-location-file sloc) + ":" + ;; +1: numbers are recorded origin-0 + (number->string (+ (single-location-line sloc) + 1)) + ":" + (number->string (+ (single-location-column sloc) + 1)) + (if (single-location-end? sloc) "(end)" "") + ) +) + +;;; Return a location in a readable form. + +(define (pretty-print-location loc) + (let ((ref-from " referenced from:")) + (string-drop + (- (string-length ref-from)) + (string-drop1 + (apply string-append + (map (lambda (sloc) + (string-append "\n" + (pretty-print-single-location sloc) + ":" + ref-from)) + (location-list loc)))))) +) + +;;; Return the top location on LOC's stack. + +(define (location-top loc) + (car (location-list loc)) +) + +;;; Return a new with FILE, LINE pushed onto the stack. + +(define (location-push-single loc file line column end?) + (make (cons (make-single-location file line column end?) + (location-list loc))) +) + +;;; Return a new with NEW-LOC preappended to LOC. + +(define (location-push loc new-loc) + (make (append (location-list new-loc) + (location-list loc))) +) + +;;; Return an unspecified . +;;; This is for use in debugging utilities. + +(define (unspecified-location) + (make (list (cons "unspecified" 1))) +) + +;;; Return a object for the current input port. +;;; END? is true if the location marks the end of the expression. + +(define (current-input-location end?) + (let ((cip (current-input-port))) + (make (list (make-single-location (port-filename cip) + (port-line cip) + (port-column cip) + end?)))) +) + +;;; An object property for tracking source locations during macro expansion. + +(define location-property (make-object-property)) + +;;; Set FORM's location to LOC. + +(define (location-property-set! form loc) + (set! (location-property form) loc) + *UNSPECIFIED* +) + ; Each named entry in the description file typically has these three members: ; name, comment attrs. @@ -97,23 +205,37 @@ ; Subclass of for use by description file objects. ; +; Records the source location of the object. +; ; We also record an internally generated entry, ordinal, to record the ; relative position within the description file. It's generally more efficient ; to record some kinds of objects (e.g. insns) in a hash table. But we also ; want to emit these objects in file order. Recording the object's relative ; position lets us generate an ordered list when we need to. +; We can't just use the line number because we want an ordering over multiple +; input files. -(define - (class-make ' '() - ;; #f for ordinal means "unassigned" - '((ordinal . #f)) +(define + (class-make ' '() + '( + ;; A object. + (location . ()) + ;; #f for ordinal means "unassigned" + (ordinal . #f) + ) '())) -(method-make! 'get-ordinal +(method-make! 'get-location + (lambda (self) (elm-get self 'location))) +(method-make! 'set-location! + (lambda (self newval) (elm-set! self 'location newval))) +(define (obj-location obj) (send obj 'get-location)) +(define (obj-set-location! obj location) (send obj 'set-location! location)) + +(method-make! 'get-ordinal (lambda (self) (elm-get self 'ordinal))) -(method-make! 'set-ordinal! +(method-make! 'set-ordinal! (lambda (self newval) (elm-set! self 'ordinal newval))) - (define (obj-ordinal obj) (send obj 'get-ordinal)) (define (obj-set-ordinal! obj ordinal) (send obj 'set-ordinal! ordinal)) @@ -718,7 +840,7 @@ ; Misc. object utilities. -; Sort a list of objects alphabetically. +; Sort a list of objects with get-name methods alphabetically. (define (alpha-sort-obj-list l) (sort l