; 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.
;
; 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
; (.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])
; .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.
(-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)
)
; 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))
(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)
(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
(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)))
; 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 <location> 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)
; 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))))
(-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 <location> 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.
; 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.
(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))
)
\f
-; Builtin macros.
+; Builtin pmacros.
; (.sym symbol1 symbol2 ...) - symbol-append, auto-convert numbers
(-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))))
)
(-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
)
; (.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)
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
(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)
)
; (.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))))))
(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
(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")
)
; 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)))
; (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> reader (keep-mach keep-isa current-cpu commands))
-(define-setters <reader> reader (keep-mach keep-isa current-cpu commands))
+(define-getters <reader> reader
+ (keep-mach keep-isa current-cpu commands location))
+(define-setters <reader> reader
+ (keep-mach keep-isa current-cpu commands location))
(define (reader-add-command! name comment attrs arg-spec handler)
(reader-set-commands! CURRENT-READER
(reader-commands CURRENT-READER)))
)
-(define (reader-lookup-command name)
+(define (-reader-lookup-command name)
(assq-ref (reader-commands CURRENT-READER) name)
)
(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))
"<input>")
":"
(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.
(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))
(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
;; 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 <location> 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.
(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*
)
\f
; Cpu data is recorded in an object of class <arch>.
(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.
; .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")
; 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.
(error "vmake: unknown options:" unrecognized))))
)
\f
+;;; Source locations are recorded as a stack, with (ideally) one extra level
+;;; for each macro invocation.
+
+(define <location> (class-make '<location>
+ nil
+ '(
+ ;; A list of "single-location" objects,
+ ;; sorted by most recent location first.
+ list
+ )
+ nil))
+
+(define-getters <location> location (list))
+(define-setters <location> 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 <location> with FILE, LINE pushed onto the stack.
+
+(define (location-push-single loc file line column end?)
+ (make <location> (cons (make-single-location file line column end?)
+ (location-list loc)))
+)
+
+;;; Return a new <location> with NEW-LOC preappended to LOC.
+
+(define (location-push loc new-loc)
+ (make <location> (append (location-list new-loc)
+ (location-list loc)))
+)
+
+;;; Return an unspecified <location>.
+;;; This is for use in debugging utilities.
+
+(define (unspecified-location)
+ (make <location> (list (cons "unspecified" 1)))
+)
+
+;;; Return a <location> 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 <location> (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*
+)
+\f
; Each named entry in the description file typically has these three members:
; name, comment attrs.
; Subclass of <ident> 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 <ordered-ident>
- (class-make '<ordered-ident> '(<ident>)
- ;; #f for ordinal means "unassigned"
- '((ordinal . #f))
+(define <source-ident>
+ (class-make '<source-ident> '(<ident>)
+ '(
+ ;; A <location> object.
+ (location . ())
+ ;; #f for ordinal means "unassigned"
+ (ordinal . #f)
+ )
'()))
-(method-make! <ordered-ident> 'get-ordinal
+(method-make! <source-ident> 'get-location
+ (lambda (self) (elm-get self 'location)))
+(method-make! <source-ident> '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! <source-ident> 'get-ordinal
(lambda (self) (elm-get self 'ordinal)))
-(method-make! <ordered-ident> 'set-ordinal!
+(method-make! <source-ident> '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))
\f
\f
; Misc. object utilities.
-; Sort a list of <ident> objects alphabetically.
+; Sort a list of objects with get-name methods alphabetically.
(define (alpha-sort-obj-list l)
(sort l
git://sourceware.org / cgen.git / commitdiff