old "errtxt" argument.
NOTE: ACU == "All Callers Updated".
* attr.scm (-parse-simple-attribute): Renamed from
parse-simple-attribute, ACU.
(-attr-parse): Change errtxt argument to context, ACU.
(-attr-read): Ditto.
(atlist-parse): Ditto. Put context arg first.
(attr-parse): Use parse-error instead of context-error.
* enum.scm (parse-enum-vals): Change errtxt argument to context, ACU.
(-enum-parse-prefix, -enum-parse, -enum-read): Ditto.
* hardware.scm (-keyword-parse): Renamed from keyword-parse.
`context' arg is now a <context> object. ACU.
(-keyword-read): `context' arg is now a <context> object. ACU.
(-hw-parse-indices): Change errtxt argument to context, ACU.
(-hw-parse-values, -hw-parse-handlers): Ditto.
(-hw-parse-getter, -hw-parse-setter, -hw-parse, -hw-read): Ditto.
(-hw-validate-layout, -hw-create-getter-from-layout,
-hw-create-setter-from-layout): Ditto.
(<hw-register>:parse!, <hw-pc>:parse!): Ditto.
(<hw-memory>:parse!, <hw-immediate>:parse!): Ditto.
(<hw-address>:parse!): Ditto.
* ifield.scm (-ifield-parse, ifield-read): Ditto.
(-ifld-parse-follows, -ifld-parse-encode-decode): Ditto.
(-ifld-parse-encode, -ifld-parse-decode): Ditto.
(-multi-ifield-parse, -multi-ifield-read): Ditto.
* insn.scm (-insn-parse, -insn-read): Ditto.
(parse-syntax): Ditto. Put context arg first.
(-parse-insn-format-symbol): Change errtxt argument to context, ACU.
(-parse-insn-format-ifield-spec, -parse-insn-format-list): Ditto.
(-parse-insn-format): Ditto.
* mach.scm (-arch-parse-alignment, -arch-parse-machs): Ditto.
(-arch-parse-isas): Ditto.
(-isa-read): Add context arg, ACU.
(-cpu-parse, -cpu-read, -mach-read): Ditto.
* minsn.scm (-minsn-parse-expansion): Change errtxt argument to
context, ACU.
(-minsn-parse, -minsn-read, -minsn-compute-iflds): Ditto.
(minsn-make-alias): Ditto.
* mode.scm (-mode-parse): Ditto.
(parse-mode-name): Ditto. Put context arg first.
* model.scm (-prefetch-parse, -retire-parse, -pipeline-parse): Change
errtxt argument to context, ACU.
(-unit-parse, -model-parse, -model-read): Ditto.
* operand.scm (-operand-parse-getter): Use parse-error instead of
context-error.
(-operand-parse-setter): Ditto.
(-operand-parse): Change errtxt argument to context, ACU.
(-operand-read, -derived-operand-parse, -derived-operand-read): Ditto.
(-anyof-operand-parse, -anyof-operand-read): Ditto.
* read.scm (reader-error): Delete. Use parse-error instead.
(parse-error): Change errtxt argument to context, ACU. Split args
argument into expr and maybe-help-text.
(-reader-process-expanded-1!): Reorganize.
* rtl.scm (-subr-read): Change errtxt argument to context, ACU.
* types.scm (parse-type): Ditto.
* utils-cgen.scm (single-location->simple-string): New function.
(<context>): Replace members file,lineno with location.
(make-prefix-context): Renamed from context-make-prefix, ACU.
(make-current-context): New function.
(context-append, context-append-name): New functions.
(context-make-reader): Delete.
(parse-name): Change errtxt argument to context, ACU.
Put context arg first.
(parse-comment): Ditto.
(parse-number): Change errtxt argument to context, ACU.
(arg-list-validate-name, arg-list-check-no-args,
arg-list-symbol-arg): Ditto.
* read.scm (-cmd-if): Don't assume test is a list.
* html.scm (get-insn-properties): Delete errtxt, unused.
+2009-08-12 Doug Evans <dje@sebabeach.org>
+
+ Clean up cpu file parsing, pass context consistently instead of the
+ old "errtxt" argument.
+ NOTE: ACU == "All Callers Updated".
+ * attr.scm (-parse-simple-attribute): Renamed from
+ parse-simple-attribute, ACU.
+ (-attr-parse): Change errtxt argument to context, ACU.
+ (-attr-read): Ditto.
+ (atlist-parse): Ditto. Put context arg first.
+ (attr-parse): Use parse-error instead of context-error.
+ * enum.scm (parse-enum-vals): Change errtxt argument to context, ACU.
+ (-enum-parse-prefix, -enum-parse, -enum-read): Ditto.
+ * hardware.scm (-keyword-parse): Renamed from keyword-parse.
+ `context' arg is now a <context> object. ACU.
+ (-keyword-read): `context' arg is now a <context> object. ACU.
+ (-hw-parse-indices): Change errtxt argument to context, ACU.
+ (-hw-parse-values, -hw-parse-handlers): Ditto.
+ (-hw-parse-getter, -hw-parse-setter, -hw-parse, -hw-read): Ditto.
+ (-hw-validate-layout, -hw-create-getter-from-layout,
+ -hw-create-setter-from-layout): Ditto.
+ (<hw-register>:parse!, <hw-pc>:parse!): Ditto.
+ (<hw-memory>:parse!, <hw-immediate>:parse!): Ditto.
+ (<hw-address>:parse!): Ditto.
+ * ifield.scm (-ifield-parse, ifield-read): Ditto.
+ (-ifld-parse-follows, -ifld-parse-encode-decode): Ditto.
+ (-ifld-parse-encode, -ifld-parse-decode): Ditto.
+ (-multi-ifield-parse, -multi-ifield-read): Ditto.
+ * insn.scm (-insn-parse, -insn-read): Ditto.
+ (parse-syntax): Ditto. Put context arg first.
+ (-parse-insn-format-symbol): Change errtxt argument to context, ACU.
+ (-parse-insn-format-ifield-spec, -parse-insn-format-list): Ditto.
+ (-parse-insn-format): Ditto.
+ * mach.scm (-arch-parse-alignment, -arch-parse-machs): Ditto.
+ (-arch-parse-isas): Ditto.
+ (-isa-read): Add context arg, ACU.
+ (-cpu-parse, -cpu-read, -mach-read): Ditto.
+ * minsn.scm (-minsn-parse-expansion): Change errtxt argument to
+ context, ACU.
+ (-minsn-parse, -minsn-read, -minsn-compute-iflds): Ditto.
+ (minsn-make-alias): Ditto.
+ * mode.scm (-mode-parse): Ditto.
+ (parse-mode-name): Ditto. Put context arg first.
+ * model.scm (-prefetch-parse, -retire-parse, -pipeline-parse): Change
+ errtxt argument to context, ACU.
+ (-unit-parse, -model-parse, -model-read): Ditto.
+ * operand.scm (-operand-parse-getter): Use parse-error instead of
+ context-error.
+ (-operand-parse-setter): Ditto.
+ (-operand-parse): Change errtxt argument to context, ACU.
+ (-operand-read, -derived-operand-parse, -derived-operand-read): Ditto.
+ (-anyof-operand-parse, -anyof-operand-read): Ditto.
+ * read.scm (reader-error): Delete. Use parse-error instead.
+ (parse-error): Change errtxt argument to context, ACU. Split args
+ argument into expr and maybe-help-text.
+ (-reader-process-expanded-1!): Reorganize.
+ * rtl.scm (-subr-read): Change errtxt argument to context, ACU.
+ * types.scm (parse-type): Ditto.
+ * utils-cgen.scm (single-location->simple-string): New function.
+ (<context>): Replace members file,lineno with location.
+ (make-prefix-context): Renamed from context-make-prefix, ACU.
+ (make-current-context): New function.
+ (context-append, context-append-name): New functions.
+ (context-make-reader): Delete.
+ (parse-name): Change errtxt argument to context, ACU.
+ Put context arg first.
+ (parse-comment): Ditto.
+ (parse-number): Change errtxt argument to context, ACU.
+ (arg-list-validate-name, arg-list-check-no-args,
+ arg-list-symbol-arg): Ditto.
+
+ * read.scm (-cmd-if): Don't assume test is a list.
+
+ * html.scm (get-insn-properties): Delete errtxt, unused.
+
2009-08-11 Doug Evans <dje@sebabeach.org>
* doc/rtl.texi (hardware types): Add pc.
(define (enum-attr-make name value) (cons name value))
-(define (parse-simple-attribute right-type? message)
- (lambda (self errtxt val)
+;;; Return a procedure to parse an attribute.
+;;; RIGHT-TYPE? is a procedure that verifies the value is the right type.
+;;; MESSAGE is printed if there is an error.
+
+(define (-parse-simple-attribute right-type? message)
+ (lambda (self context val)
(if (and (not (null? val))
(right-type? (car val))
(null? (cdr val)))
(cons (obj:name self) (car val))
- (parse-error errtxt message (cons (obj:name self) val))))
+ (parse-error context message (cons (obj:name self) val))))
)
; A boolean attribute's value is either #t or #f.
(method-make!
<boolean-attribute> 'parse-value
- (parse-simple-attribute boolean? "boolean attribute not one of #f/#t")
+ (-parse-simple-attribute boolean? "boolean attribute not one of #f/#t")
)
(method-make!
<string-attribute> 'parse-value
- (parse-simple-attribute string? "invalid argument to string attribute"))
+ (-parse-simple-attribute string? "invalid argument to string attribute"))
; A bitset attribute's value is a comma separated list of elements.
; We don't validate the values. In the case of the MACH attribute,
(method-make!
<bitset-attribute> 'parse-value
- (parse-simple-attribute (lambda (x) (or (symbol? x) (string? x)))
- "improper bitset attribute")
+ (-parse-simple-attribute (lambda (x) (or (symbol? x) (string? x)))
+ "improper bitset attribute")
)
; An integer attribute's value is a number
(method-make!
<integer-attribute> 'parse-value
- (parse-simple-attribute (lambda (x) (or (number? x) (symbol? x)))
- "improper integer attribute")
+ (-parse-simple-attribute (lambda (x) (or (number? x) (symbol? x)))
+ "improper integer attribute")
)
; An enum attribute's value is a symbol representing that value.
(method-make!
<enum-attribute> 'parse-value
- (parse-simple-attribute (lambda (x) (or (symbol? x) (string? x)))
- "improper enum attribute")
+ (-parse-simple-attribute (lambda (x) (or (symbol? x) (string? x)))
+ "improper enum attribute")
)
; Parse a boolean attribute's value definition.
(method-make!
<boolean-attribute> 'parse-value-def
- (lambda (self errtxt values)
+ (lambda (self context values)
(if (equal? values '(#f #t))
values
- (parse-error errtxt "boolean value list must be (#f #t)" values)))
+ (parse-error context "boolean value list must be (#f #t)" values)))
)
; Ignore values for strings. We can't do any error checking since
(method-make!
<string-attribute> 'parse-value-def
- (lambda (self errtxt values) #f)
+ (lambda (self context values) #f)
)
; Parse a bitset attribute's value definition.
(method-make!
<bitset-attribute> 'parse-value-def
- (lambda (self errtxt values)
- (parse-enum-vals errtxt "" values))
+ (lambda (self context values)
+ (parse-enum-vals context "" values))
)
; Parse an integer attribute's value definition.
(method-make!
<integer-attribute> 'parse-value-def
- (lambda (self errtxt values)
+ (lambda (self context values)
(if values
(for-each (lambda (val)
(if (or (not (list? val))
(not (number? (car val))))
- (parse-error errtxt "invalid element in integer attribute list" val)))
+ (parse-error context
+ "invalid element in integer attribute list"
+ val)))
values))
values)
)
(method-make!
<enum-attribute> 'parse-value-def
- (lambda (self errtxt values)
- (parse-enum-vals errtxt "" values))
+ (lambda (self context values)
+ (parse-enum-vals context "" values))
)
; Make an attribute list object from a list of name/value pairs.
; If DEFAULT is #f, use the first value.
; ??? Allowable values for integer attributes is wip.
-(define (-attr-parse errtxt type-class name comment attrs for default values)
+(define (-attr-parse context type-class name comment attrs for default values)
(logit 2 "Processing attribute " name " ...\n")
- (let* ((name (parse-name name errtxt))
- (errtxt (stringsym-append errtxt ":" name))
+
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name))
(result (new type-class))
- (parsed-values (send result 'parse-value-def errtxt values)))
+ (parsed-values (send result 'parse-value-def context values)))
+
(elm-xset! result 'name name)
- (elm-xset! result 'comment (parse-comment comment errtxt))
- (elm-xset! result 'attrs (atlist-parse attrs "" errtxt))
+ (elm-xset! result 'comment (parse-comment context comment))
+ (elm-xset! result 'attrs (atlist-parse context attrs ""))
(elm-xset! result 'for for)
; Set the default.
(case (class-name type-class)
((<boolean-attribute>)
(if (and (not (memq default '(#f #t)))
(not (rtx? default)))
- (parse-error errtxt "invalid default" default))
+ (parse-error context "invalid default" default))
(elm-xset! result 'default default))
((<string-attribute>)
(let ((default (or default "")))
(if (and (not (string? default))
(not (rtx? default)))
- (parse-error errtxt "invalid default" default))
+ (parse-error context "invalid default" default))
(elm-xset! result 'default default)))
((<integer-attribute>)
(let ((default (if default default (if (null? values) 0 (car values)))))
(if (and (not (integer? default))
(not (rtx? default)))
- (parse-error errtxt "invalid default" default))
+ (parse-error context "invalid default" default))
(elm-xset! result 'default default)))
((<bitset-attribute> <enum-attribute>)
(let ((default (if default default (caar parsed-values))))
(if (and (not (assq default parsed-values))
(not (rtx? default)))
- (parse-error errtxt "invalid default" default))
+ (parse-error context "invalid default" default))
(elm-xset! result 'default default))))
(elm-xset! result 'values parsed-values)
+
result)
)
; Read an attribute description
; This is the main routine for analyzing attributes in the .cpu file.
-; ERRTXT is prepended to error messages to provide context.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
; -attr-parse is invoked to create the attribute object.
-(define (-attr-read errtxt . arg-list)
- (let (; Current attribute elements:
+(define (-attr-read context . arg-list)
+ (let (
(type-class 'not-set) ; attribute type
- (name nil)
+ (name #f)
(comment "")
(attrs nil)
(for #f) ; assume for everything
- (default #f) ; indicates "not set"
- (values #f) ; indicates "not set"
+ (default #f) ; #f indicates "not set"
+ (values #f) ; #f indicates "not set"
)
+
; Loop over each element in ARG-LIST, recording what's found.
(let loop ((arg-list arg-list))
(if (null? arg-list)
((integer) <integer-attribute>)
((enum) <enum-attribute>)
(else (parse-error
- errtxt
+ context
"invalid attribute type"
(cadr arg))))))
((name) (set! name (cadr arg)))
((for) (set! for (cdr arg)))
((default) (set! default (cadr arg)))
((values) (set! values (cdr arg)))
- (else (parse-error errtxt "invalid attribute arg" arg)))
+ (else (parse-error context "invalid attribute arg" arg)))
(loop (cdr arg-list)))))
+
; Must have type now.
(if (eq? type-class 'not-set)
- (parse-error errtxt "type not specified"))
+ (parse-error context "type not specified") arg-list)
; Establish proper defaults now that we know the type.
(case (class-name type-class)
((<boolean-attribute>)
(set! values '(#f #t))))
((bitset-attribute>) ;; FIXME
(if (eq? default #f)
- (parse-error errtxt "bitset-attribute default not specified"))
+ (parse-error context "bitset-attribute default not specified"
+ arg-list))
(if (eq? values #f)
- (parse-error errtxt "bitset-attribute values not specified")))
+ (parse-error context "bitset-attribute values not specified"
+ arg-list)))
((integer-attribute>) ;; FIXME
(if (eq? default #f)
(set! default 0))
(set! values #f))) ; really a nop, but for consistency
((enum-attribute>) ;; FIXME
(if (eq? default #f)
- (parse-error errtxt "enum-attribute default not specified"))
+ (parse-error context "enum-attribute default not specified"
+ arg-list))
(if (eq? values #f)
- (parse-error errtxt "bitset-attribute values not specified")))
+ (parse-error context "bitset-attribute values not specified"
+ arg-list)))
)
+
; Now that we've identified the elements, build the object.
- (-attr-parse errtxt type-class name comment attrs for default values)
- )
+ (-attr-parse context type-class name comment attrs for default values))
)
; Main routines for defining attributes in .cpu files.
(define define-attr
(lambda arg-list
- (let ((a (apply -attr-read (cons "define-attr" arg-list))))
+ (let ((a (apply -attr-read (cons (make-current-context "define-attr")
+ arg-list))))
(current-attr-add! a)
a))
)
(define (attr-parse context attrs)
(if (not (list? attrs))
- (context-error context "improper attribute list" attrs))
+ (parse-error context "improper attribute list" attrs))
(let ((alist nil))
(for-each (lambda (elm)
(cond ((symbol? elm)
(set! alist (acons (string->symbol (string-drop1 (symbol->string elm))) #f alist))
(set! alist (acons elm #t alist)))
(if (not (current-attr-lookup (caar alist)))
- (context-error context "unknown attribute" (caar alist))))
+ (parse-error context "unknown attribute" (caar alist))))
((and (list? elm) (pair? elm) (symbol? (car elm)))
(let ((a (current-attr-lookup (car elm))))
(if (not a)
- (context-error context "unknown attribute" elm))
+ (parse-error context "unknown attribute" elm))
(set! alist (cons (send a 'parse-value
- (context-prefix context);FIXME
- (cdr elm)) alist))))
- (else (context-error context "improper attribute" elm))))
+ context (cdr elm))
+ alist))))
+ (else (parse-error context "improper attribute" elm))))
attrs)
alist)
)
; ATTRS is a list of attribute specs (e.g. (FOO !BAR (BAZ 3))).
; The result is an <attr-list> object.
-(define (atlist-parse attrs prefix errtxt)
- (make <attr-list> prefix (attr-parse (context-make-prefix errtxt) attrs))
+(define (atlist-parse context attrs prefix)
+ (make <attr-list> prefix (attr-parse context attrs))
)
; Return the source form of an atlist's values.
; The result is the same list, except values are filled in where missing,
; and each symbol is prepended with `prefix'.
-(define (parse-enum-vals errtxt prefix vals)
+(define (parse-enum-vals context prefix vals)
; Scan the value list, building up RESULT as we go.
; Each element's value is 1+ the previous, unless there's an explicit value.
(let loop ((result nil) (last -1) (remaining vals))
; Utility of -enum-parse to parse the prefix.
-(define (-enum-parse-prefix errtxt prefix)
+(define (-enum-parse-prefix context prefix)
(if (symbol? prefix)
(set! prefix (symbol->string prefix)))
(if (not (string? prefix))
- (parse-error errtxt "prefix is not a string" prefix))
+ (parse-error context "prefix is not a string" prefix))
; Prefix must not contain lowercase chars (enforced style rule, sue me).
(if (any-true? (map char-lower-case? (string->list prefix)))
- (parse-error errtxt "prefix must be uppercase" prefix))
+ (parse-error context "prefix must be uppercase" prefix))
prefix
)
; description in the .cpu file.
; All arguments are in raw (non-evaluated) form.
-(define (-enum-parse errtxt name comment attrs prefix vals)
+(define (-enum-parse context name comment attrs prefix vals)
(logit 2 "Processing enum " name " ...\n")
- (let* ((name (parse-name name errtxt))
- (errtxt (stringsym-append errtxt " " name)))
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name)))
(make <enum>
name
- (parse-comment comment errtxt)
- (atlist-parse attrs "enum" errtxt)
- (-enum-parse-prefix errtxt prefix)
- (parse-enum-vals errtxt prefix vals)))
+ (parse-comment context comment)
+ (atlist-parse context attrs "enum")
+ (-enum-parse-prefix context prefix)
+ (parse-enum-vals context prefix vals)))
)
; Read an enum description
; This is the main routine for analyzing enums in the .cpu file.
-; ERRTXT is prepended to error messages to provide context.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
; -enum-parse is invoked to create the `enum' object.
-(define (-enum-read errtxt . arg-list)
- (let (; Current enum elements:
- (name nil) ; name of field
- (comment "") ; description of field
- (attrs nil) ; attributes
- (prefix "") ; prepended to each element's name
- (values nil) ; enum values
+(define (-enum-read context . arg-list)
+ (let (
+ (name #f)
+ (comment "")
+ (attrs nil)
+ (prefix "")
+ (values nil)
)
+
; Loop over each element in ARG-LIST, recording what's found.
(let loop ((arg-list arg-list))
(if (null? arg-list)
((attrs) (set! attrs (cdr arg)))
((prefix) (set! prefix (cadr arg)))
((values) (set! values (cadr arg)))
- (else (parse-error errtxt "invalid enum arg" arg)))
+ (else (parse-error context "invalid enum arg" arg)))
(loop (cdr arg-list)))))
+
; Now that we've identified the elements, build the object.
- (-enum-parse errtxt name comment attrs prefix values)
- )
+ (-enum-parse context name comment attrs prefix values))
)
; Define an enum object, name/value pair list version.
(define define-enum
(lambda arg-list
- (let ((e (apply -enum-read (cons "define-enum" arg-list))))
+ (let ((e (apply -enum-read (cons (make-current-context "define-enum")
+ arg-list))))
(current-enum-add! e)
e))
)
; Define an enum object, all arguments specified.
(define (define-full-enum name comment attrs prefix vals)
- (let ((e (-enum-parse "define-full-enum" name comment attrs prefix vals)))
+ (let ((e (-enum-parse (make-current-context "define-full-enum")
+ name comment attrs prefix vals)))
(current-enum-add! e)
e)
)
; Define an insn enum, all arguments specified.
(define (define-full-insn-enum name comment attrs prefix fld vals)
- (let* ((errtxt "define-full-insn-enum")
- (atlist (atlist-parse attrs "insn_enum" errtxt))
+ (let* ((context (make-current-context "define-full-insn-enum"))
+ (atlist (atlist-parse context attrs "insn-enum"))
(fld-obj (current-ifld-lookup fld)))
(if (keep-isa-atlist? atlist #f)
(begin
(if (not fld-obj)
- (parse-error errtxt "unknown insn field" fld))
+ (parse-error context "unknown insn field" fld))
; Create enum object and add it to the list of enums.
(let ((e (make <insn-enum>
- (parse-name name errtxt)
- (parse-comment comment errtxt)
- (atlist-parse attrs "insn-enum" errtxt)
- (-enum-parse-prefix errtxt prefix)
+ (parse-name context name)
+ (parse-comment context comment)
+ atlist
+ (-enum-parse-prefix context prefix)
fld-obj
- (parse-enum-vals errtxt prefix vals))))
+ (parse-enum-vals context prefix vals))))
(current-enum-add! e)
e))))
- )
+)
\f
(define (enum-init!)
; that is left to the application. Still, it might be preferable to impose
; some restrictions which can later be relaxed as necessary.
-(define (keyword-parse context name comment attrs mode print-name prefix values)
+(define (-keyword-parse context name comment attrs mode print-name prefix values)
; FIXME: parse values.
(let ((result (make <keyword>
- (parse-name name context)
- (parse-comment comment context)
- (atlist-parse attrs "" context)
- (parse-mode-name mode (string-append context ": mode"))
- (parse-string (string-append context ": print-name") print-name)
- (parse-string (string-append context ": prefix") prefix)
+ (parse-name context name)
+ (parse-comment context comment)
+ (atlist-parse context attrs "")
+ (parse-mode-name (context-append context ": mode") mode)
+ (parse-string (context-append context ": print-name")
+ print-name)
+ (parse-string (context-append context ": prefix")
+ prefix)
values)))
result)
)
; Read a keyword description
; This is the main routine for analyzing a keyword description in the .cpu
; file.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; keyword-parse is invoked to create the <keyword> object.
+; -keyword-parse is invoked to create the <keyword> object.
(define (-keyword-read context . arg-list)
- (let ((name #f)
+ (let (
+ (name #f)
(comment "")
(attrs nil)
(mode INT)
- (print-name #f)
+ (print-name #f) ;; #f indicates "not set"
(prefix "")
(values nil)
)
+
; Loop over each element in ARG-LIST, recording what's found.
(let loop ((arg-list arg-list))
(if (null? arg-list)
((values) (set! values (cdr arg)))
(else (parse-error context "invalid hardware arg" arg)))
(loop (cdr arg-list)))))
+
; Now that we've identified the elements, build the object.
- (keyword-parse context name comment attrs mode
- (or print-name name)
- prefix values)
- )
+ (-keyword-parse context name comment attrs mode
+ (or print-name name)
+ prefix values))
)
; Define a keyword object, name/value pair list version.
(define define-keyword
(lambda arg-list
- (let ((kw (apply -keyword-read (cons "define-keyword" arg-list))))
+ (let ((kw (apply -keyword-read (cons (make-current-context "define-keyword")
+ arg-list))))
(if kw
(begin
(current-kw-add! kw)
; They're needed to output the table.
; ??? This isn't quite right as the container may contain multiple keyword
; instances. To be fixed in time.
- (keyword-parse context (obj:name container) (obj:comment container)
- ; PRIVATE: keyword table is implicitly defined and made
- ; "static" (in the C sense).
- (cons 'PRIVATE (atlist-source-form (obj-atlist container)))
- mode
- (obj:name container) ; print-name
- (car args) ; prefix
- (cadr args)) ; value
+ (-keyword-parse context (obj:name container) (obj:comment container)
+ ;; PRIVATE: keyword table is implicitly defined and made
+ ;; "static" (in the C sense).
+ (cons 'PRIVATE (atlist-source-form (obj-atlist container)))
+ mode
+ (obj:name container) ; print-name
+ (car args) ; prefix
+ (cadr args)) ; value
)
; Parse an indices spec.
; Otherwise MODE is used.
; The syntax is: (keyword keyword-spec) - see <keyword> for details.
-(define (-hw-parse-indices errtxt indices container mode)
+(define (-hw-parse-indices context indices container mode)
(if (null? indices)
(make <hw-asm>
(obj:name container) (obj:comment container) (obj-atlist container)
mode)
(begin
(if (not (list? indices))
- (parse-error errtxt "invalid indices spec" indices))
+ (parse-error context "invalid indices spec" indices))
(case (car indices)
- ((keyword) (-hw-parse-keyword errtxt (cdr indices) container mode))
+ ((keyword) (-hw-parse-keyword context (cdr indices) container mode))
((extern-keyword) (begin
(if (null? (cdr indices))
- (parse-error errtxt "missing keyword name"
+ (parse-error context "missing keyword name"
indices))
(let ((kw (current-kw-lookup (cadr indices))))
(if (not kw)
- (parse-error errtxt "unknown keyword"
+ (parse-error context "unknown keyword"
indices))
kw)))
- (else (parse-error errtxt "unknown indices type" (car indices))))))
+ (else (parse-error context "unknown indices type" (car indices))))))
)
; Parse a values spec.
; Otherwise MODE is used.
; The syntax is: (keyword keyword-spec) - see <keyword> for details.
-(define (-hw-parse-values errtxt values container mode)
+(define (-hw-parse-values context values container mode)
(if (null? values)
(make <hw-asm>
(obj:name container) (obj:comment container) (obj-atlist container)
mode)
(begin
(if (not (list? values))
- (parse-error errtxt "invalid values spec" values))
+ (parse-error context "invalid values spec" values))
(case (car values)
- ((keyword) (-hw-parse-keyword errtxt (cdr values) container mode))
+ ((keyword) (-hw-parse-keyword context (cdr values) container mode))
((extern-keyword) (begin
(if (null? (cdr values))
- (parse-error errtxt "missing keyword name"
+ (parse-error context "missing keyword name"
values))
(let ((kw (current-kw-lookup (cadr values))))
(if (not kw)
- (parse-error errtxt "unknown keyword"
+ (parse-error context "unknown keyword"
values))
kw)))
- (else (parse-error errtxt "unknown values type" (car values))))))
+ (else (parse-error context "unknown values type" (car values))))))
)
; Parse a handlers spec.
; Each element is (name "string").
-(define (-hw-parse-handlers errtxt handlers)
- (parse-handlers errtxt '(parse print) handlers)
+(define (-hw-parse-handlers context handlers)
+ (parse-handlers context '(parse print) handlers)
)
; Parse a getter spec.
; Omit `index' for scalar objects.
; Externally they're specified as `get'. Internally we use `getter'.
-(define (-hw-parse-getter errtxt getter scalar?)
+(define (-hw-parse-getter context getter scalar?)
(if (null? getter)
#f ; use default
(let ((valid "((index) (expression))")
(!= (length getter) 2)
(not (and (list? (car getter))
(= (length (car getter)) (if scalar? 0 1)))))
- (parse-error errtxt
+ (parse-error context
(string-append "invalid getter, should be "
(if scalar? scalar-valid valid))
getter))
(if (not (rtx? (cadr getter)))
- (parse-error errtxt "invalid rtx expression" getter))
+ (parse-error context "invalid rtx expression" getter))
getter))
)
; Omit `index' for scalar objects.
; Externally they're specified as `set'. Internally we use `setter'.
-(define (-hw-parse-setter errtxt setter scalar?)
+(define (-hw-parse-setter context setter scalar?)
(if (null? setter)
#f ; use default
(let ((valid "((index newval) (expression))")
(!= (length setter) 2)
(not (and (list? (car setter))
(= (length (car setter)) (if scalar? 1 2)))))
- (parse-error errtxt
+ (parse-error context
(string-append "invalid setter, should be "
(if scalar? scalar-valid valid))
setter))
(if (not (rtx? (cadr setter)))
- (parse-error errtxt "invalid rtx expression" setter))
+ (parse-error context "invalid rtx expression" setter))
setter))
)
; ??? Might want to redo to handle hardware type specific specs more cleanly.
; E.g. <hw-immediate> shouldn't have to see get/set specs.
-(define (-hw-parse errtxt name comment attrs semantic-name type
+(define (-hw-parse context name comment attrs semantic-name type
indices values handlers get set layout)
(logit 2 "Processing hardware element " name " ...\n")
(if (null? type)
- (parse-error errtxt "missing hardware type" name))
+ (parse-error context "missing hardware type" name))
- ; Pick out name first 'cus we need it as a string(/symbol).
- (let ((name (parse-name name "hardware"))
- (class-name (assq-ref -hardware-types (car type)))
- (atlist-obj (atlist-parse attrs "cgen_hw" errtxt)))
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name))
+ (class-name (assq-ref -hardware-types (car type)))
+ (atlist-obj (atlist-parse context attrs "cgen_hw")))
(if (not class-name)
- (parse-error errtxt "unknown hardware type" type))
+ (parse-error context "unknown hardware type" type))
(if (keep-atlist? atlist-obj #f)
(let ((result (new (class-lookup class-name))))
(send result 'set-name! name)
- (send result 'set-comment! (parse-comment comment errtxt))
+ (send result 'set-comment! (parse-comment context comment))
(send result 'set-atlist! atlist-obj)
(elm-xset! result 'sem-name semantic-name)
- (send result 'parse! errtxt
+ (send result 'parse! context
(cdr type) indices values handlers get set layout)
; If this is a virtual reg, get/set specs must be provided.
(if (and (obj-has-attr? result 'VIRTUAL)
(not (and (hw-getter result) (hw-setter result))))
- (parse-error errtxt "virtual reg requires get/set specs" name))
+ (parse-error context "virtual reg requires get/set specs" name))
; If get or set specs are specified, can't have CACHE-ADDR.
(if (and (obj-has-attr? result 'CACHE-ADDR)
(or (hw-getter result) (hw-setter result)))
- (parse-error errtxt "can't have CACHE-ADDR with get/set specs" name))
+ (parse-error context "can't have CACHE-ADDR with get/set specs"
+ name))
result)
(begin
; Read a hardware description
; This is the main routine for analyzing a hardware description in the .cpu
; file.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
; -hw-parse is invoked to create the <hardware> object.
-(define (-hw-read errtxt . arg-list)
- (let ((name nil) ; name of hardware
+(define (-hw-read context . arg-list)
+ (let (
+ (name nil)
(comment "")
(attrs nil)
(semantic-name nil) ; name used in semantics, default is `name'
(set nil)
(layout nil)
)
+
; Loop over each element in ARG-LIST, recording what's found.
(let loop ((arg-list arg-list))
(if (null? arg-list)
((get) (set! get (cdr arg)))
((set) (set! set (cdr arg)))
((layout) (set! layout (cdr arg)))
- (else (parse-error errtxt "invalid hardware arg" arg)))
+ (else (parse-error context "invalid hardware arg" arg)))
(loop (cdr arg-list)))))
+
; Now that we've identified the elements, build the object.
- (-hw-parse errtxt name comment attrs
+ (-hw-parse context name comment attrs
(if (null? semantic-name) name semantic-name)
- type indices values handlers get set layout)
- )
+ type indices values handlers get set layout))
)
; Define a hardware object, name/value pair list version.
(define define-hardware
(lambda arg-list
- (let ((hw (apply -hw-read (cons "define-hardware" arg-list))))
+ (let ((hw (apply -hw-read (cons (make-current-context "define-hardware")
+ arg-list))))
(if hw
(current-hw-add! hw))
hw))
(define (define-full-hardware name comment attrs semantic-name type
indices values handlers get set layout)
- (let ((hw (-hw-parse "define-full-hardware"
+ (let ((hw (-hw-parse (make-current-context "define-full-hardware")
name comment attrs semantic-name type
indices values handlers get set layout)))
(if hw
(define modify-hardware
(lambda arg-list
- (let ((errtxt "modify-hardware"))
+ (let ((context (make-current-context "modify-hardware")))
; FIXME: Experiment. This implements the :name/value style by
; converting it to (name value). In the end there shouldn't be two
; There's no requirement that the name be specified first.
(let ((hw-spec (assq 'name arg-list)))
(if (not hw-spec)
- (parse-error errtxt "hardware name not specified"))
+ (parse-error context "hardware name not specified" arg-list))
- (let ((hw (current-hw-lookup (arg-list-symbol-arg errtxt hw-spec))))
+ (let ((hw (current-hw-lookup (arg-list-symbol-arg context hw-spec))))
(if (not hw)
- (parse-error errtxt "undefined hardware element" hw-spec))
+ (parse-error context "undefined hardware element" hw-spec))
; Process the rest of the args now that we have the affected object.
(let loop ((args arg-list))
(case (car arg-spec)
((name) #f) ; ignore, already processed
((add-attrs)
- (let ((atlist-obj (atlist-parse (cdr arg-spec)
- "cgen_hw" errtxt)))
+ (let ((atlist-obj (atlist-parse context (cdr arg-spec)
+ "cgen_hw")))
; prepend attrs so new ones override existing ones
(obj-prepend-atlist! hw atlist-obj)))
(else
- (parse-error errtxt "invalid/unsupported option" (car arg-spec))))
+ (parse-error context "invalid/unsupported option"
+ (car arg-spec))))
(loop (cdr args))))))))
*UNSPECIFIED*)
; - (value length)
; - hardware-name
-(define (-hw-validate-layout errtxt layout width)
+(define (-hw-validate-layout context layout width)
(if (not (list? layout))
- (parse-error errtxt "layout is not a list" layout))
+ (parse-error context "layout is not a list" layout))
(let loop ((layout layout) (shift 0))
(if (null? layout)
(begin
; Done. Now see if number of bits in layout matches total width.
(if (not (= shift width))
- (parse-error errtxt (string-append
- "insufficient number of bits (need "
- (number->string width)
- ")")
+ (parse-error context (string-append
+ "insufficient number of bits (need "
+ (number->string width)
+ ")")
shift)))
; Validate next entry.
(let ((val (car layout)))
(cond ((number? val)
(if (not (memq val '(0 1)))
- (parse-error errtxt
+ (parse-error context
"non 0/1 layout entry requires length"
val))
(loop (cdr layout) (1+ shift)))
(not (pair? (cdr val)))
(not (number? (cadr val)))
(not (null? (cddr val))))
- (parse-error errtxt
+ (parse-error context
"syntax error in layout, expecting `(value length)'"
val))
(loop (cdr layout) (+ shift (cadr val))))
((symbol? val)
(let ((hw (current-hw-lookup val)))
(if (not hw)
- (parse-error errtxt "unknown hardware element" val))
+ (parse-error context "unknown hardware element" val))
(if (not (hw-scalar? hw))
- (parse-error errtxt "non-scalar hardware element" val))
+ (parse-error context "non-scalar hardware element" val))
(loop (cdr layout)
(+ shift (hw-bits hw)))))
(else
- (parse-error errtxt "bad layout element" val))))))
+ (parse-error context "bad layout element" val))))))
+
*UNSPECIFIED*
)
; (or SI (sll SI (zext SI (reg h-hw2)) 1)
; (zext SI (reg h-hw3)))))
-(define (-hw-create-getter-from-layout errtxt layout width)
+(define (-hw-create-getter-from-layout context layout width)
(let ((add-to-res (lambda (result mode-name val shift)
(if (null? result)
(rtx-make 'sll mode-name val shift)
; (set (reg h-hw3) (and (srl val 0) 1))
; ))
-(define (-hw-create-setter-from-layout errtxt layout width)
+(define (-hw-create-setter-from-layout context layout width)
(let ((mode-name (obj:name (mode-find width 'UINT))))
(let loop ((sets nil) (layout (reverse layout)) (shift 0))
(if (null? layout)
(method-make!
<hw-register> 'parse!
- (lambda (self errtxt type indices values handlers getter setter layout)
+ (lambda (self context type indices values handlers getter setter layout)
(if (or (null? type)
(> (length type) 2))
- (parse-error errtxt "invalid register spec" type))
+ (parse-error context "invalid register spec" type))
(if (and (= (length type) 2)
(or (not (list? (cadr type)))
(> (length (cadr type)) 1)))
- (parse-error errtxt "bad register dimension spec" type))
+ (parse-error context "bad register dimension spec" type))
; Must parse and set type before analyzing LAYOUT.
- (elm-set! self 'type (parse-type errtxt type))
+ (elm-set! self 'type (parse-type context type))
; LAYOUT is a shorthand way of specifying getter/setter specs.
; For registers that are just a collection of other registers
; We don't override any provided get/set specs though.
(if (not (null? layout))
(let ((width (hw-bits self)))
- (-hw-validate-layout errtxt layout width)
+ (-hw-validate-layout context layout width)
(if (null? getter)
(set! getter
- (-hw-create-getter-from-layout errtxt layout width)))
+ (-hw-create-getter-from-layout context layout width)))
(if (null? setter)
(set! setter
- (-hw-create-setter-from-layout errtxt layout width)))
+ (-hw-create-setter-from-layout context layout width)))
))
- (elm-set! self 'indices (-hw-parse-indices errtxt indices self UINT))
- (elm-set! self 'values (-hw-parse-values errtxt values self
+ (elm-set! self 'indices (-hw-parse-indices context indices self UINT))
+ (elm-set! self 'values (-hw-parse-values context values self
(send (elm-get self 'type)
'get-mode)))
- (elm-set! self 'handlers (-hw-parse-handlers errtxt handlers))
- (elm-set! self 'get (-hw-parse-getter errtxt getter (hw-scalar? self)))
- (elm-set! self 'set (-hw-parse-setter errtxt setter (hw-scalar? self)))
+ (elm-set! self 'handlers (-hw-parse-handlers context handlers))
+ (elm-set! self 'get (-hw-parse-getter context getter (hw-scalar? self)))
+ (elm-set! self 'set (-hw-parse-setter context setter (hw-scalar? self)))
*UNSPECIFIED*)
)
(method-make!
<hw-pc> 'parse!
- (lambda (self errtxt type indices values handlers getter setter layout)
+ (lambda (self context type indices values handlers getter setter layout)
(if (not (null? type))
- (elm-set! self 'type (parse-type errtxt type))
+ (elm-set! self 'type (parse-type context type))
(elm-set! self 'type (make <scalar> (mode:lookup 'IAI))))
(if (not (null? indices))
- (parse-error errtxt "indices specified for pc" indices))
+ (parse-error context "indices specified for pc" indices))
(if (not (null? values))
- (parse-error errtxt "values specified for pc" values))
+ (parse-error context "values specified for pc" values))
(if (not (null? layout))
- (parse-error errtxt "layout specified for pc" values))
+ (parse-error context "layout specified for pc" values))
; The initial value of INDICES, VALUES is #f which is what we want.
- (elm-set! self 'handlers (-hw-parse-handlers errtxt handlers))
- (elm-set! self 'get (-hw-parse-getter errtxt getter (hw-scalar? self)))
- (elm-set! self 'set (-hw-parse-setter errtxt setter (hw-scalar? self)))
+ (elm-set! self 'handlers (-hw-parse-handlers context handlers))
+ (elm-set! self 'get (-hw-parse-getter context getter (hw-scalar? self)))
+ (elm-set! self 'set (-hw-parse-setter context setter (hw-scalar? self)))
*UNSPECIFIED*)
)
(method-make!
<hw-memory> 'parse!
- (lambda (self errtxt type indices values handlers getter setter layout)
+ (lambda (self context type indices values handlers getter setter layout)
(if (or (null? type)
(> (length type) 2))
- (parse-error errtxt "invalid memory spec" type))
+ (parse-error context "invalid memory spec" type))
(if (and (= (length type) 2)
(or (not (list? (cadr type)))
(> (length (cadr type)) 1)))
- (parse-error errtxt "bad memory dimension spec" type))
+ (parse-error context "bad memory dimension spec" type))
(if (not (null? layout))
- (parse-error errtxt "layout specified for memory" values))
- (elm-set! self 'type (parse-type errtxt type))
+ (parse-error context "layout specified for memory" values))
+ (elm-set! self 'type (parse-type context type))
; Setting INDICES,VALUES here is mostly for experimentation at present.
- (elm-set! self 'indices (-hw-parse-indices errtxt indices self AI))
- (elm-set! self 'values (-hw-parse-values errtxt values self
+ (elm-set! self 'indices (-hw-parse-indices context indices self AI))
+ (elm-set! self 'values (-hw-parse-values context values self
(send (elm-get self 'type)
'get-mode)))
- (elm-set! self 'handlers (-hw-parse-handlers errtxt handlers))
- (elm-set! self 'get (-hw-parse-getter errtxt getter (hw-scalar? self)))
- (elm-set! self 'set (-hw-parse-setter errtxt setter (hw-scalar? self)))
+ (elm-set! self 'handlers (-hw-parse-handlers context handlers))
+ (elm-set! self 'get (-hw-parse-getter context getter (hw-scalar? self)))
+ (elm-set! self 'set (-hw-parse-setter context setter (hw-scalar? self)))
*UNSPECIFIED*)
)
(method-make!
<hw-immediate> 'parse!
- (lambda (self errtxt type indices values handlers getter setter layout)
+ (lambda (self context type indices values handlers getter setter layout)
(if (not (= (length type) 1))
- (parse-error errtxt "invalid immediate spec" type))
- (elm-set! self 'type (parse-type errtxt type))
+ (parse-error context "invalid immediate spec" type))
+ (elm-set! self 'type (parse-type context type))
; An array of immediates may be useful some day, but not yet.
(if (not (null? indices))
- (parse-error errtxt "indices specified for immediate" indices))
+ (parse-error context "indices specified for immediate" indices))
(if (not (null? layout))
- (parse-error errtxt "layout specified for immediate" values))
- (elm-set! self 'values (-hw-parse-values errtxt values self
+ (parse-error context "layout specified for immediate" values))
+ (elm-set! self 'values (-hw-parse-values context values self
(send (elm-get self 'type)
'get-mode)))
- (elm-set! self 'handlers (-hw-parse-handlers errtxt handlers))
+ (elm-set! self 'handlers (-hw-parse-handlers context handlers))
(if (not (null? getter))
- (parse-error errtxt "getter specified for immediate" getter))
+ (parse-error context "getter specified for immediate" getter))
(if (not (null? setter))
- (parse-error errtxt "setter specified for immediate" setter))
+ (parse-error context "setter specified for immediate" setter))
*UNSPECIFIED*)
)
(method-make!
<hw-address> 'parse!
- (lambda (self errtxt type indices values handlers getter setter layout)
+ (lambda (self context type indices values handlers getter setter layout)
(if (not (null? type))
- (parse-error errtxt "invalid address spec" type))
+ (parse-error context "invalid address spec" type))
(elm-set! self 'type (make <scalar> AI))
(if (not (null? indices))
- (parse-error errtxt "indices specified for address" indices))
+ (parse-error context "indices specified for address" indices))
(if (not (null? values))
- (parse-error errtxt "values specified for address" values))
+ (parse-error context "values specified for address" values))
(if (not (null? layout))
- (parse-error errtxt "layout specified for address" values))
- (elm-set! self 'values (-hw-parse-values errtxt values self
+ (parse-error context "layout specified for address" values))
+ (elm-set! self 'values (-hw-parse-values context values self
(send (elm-get self 'type)
'get-mode)))
- (elm-set! self 'handlers (-hw-parse-handlers errtxt handlers))
+ (elm-set! self 'handlers (-hw-parse-handlers context handlers))
(if (not (null? getter))
- (parse-error errtxt "getter specified for address" getter))
+ (parse-error context "getter specified for address" getter))
(if (not (null? setter))
- (parse-error errtxt "setter specified for address" setter))
+ (parse-error context "setter specified for address" setter))
*UNSPECIFIED*)
)
(let*
((context #f) ; ??? do we need a better context?
- ; String for error messages.
- (errtxt "semantic attribute computation for html")
-
; List of attributes computed from SEM-CODE-LIST.
; The first element is just a dummy so that append! always works.
(sem-attrs (list #f))
;
; FIXME: More error checking.
-(define (-ifield-parse errtxt name comment attrs
+(define (-ifield-parse context name comment attrs
word-offset word-length start flength follows
mode encode decode)
(logit 2 "Processing ifield " name " ...\n")
- (let* ((name (parse-name name errtxt))
- (atlist (atlist-parse attrs "cgen_ifld" errtxt))
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name))
+ (atlist (atlist-parse context attrs "cgen_ifld"))
(isas (bitset-attr->list (atlist-attr-value atlist 'ISA #f))))
; No longer ensure only one isa specified.
;(if (!= (length isas) 1)
- ; (parse-error errtxt "can only specify 1 isa" attrs))
+ ; (parse-error context "can only specify 1 isa" attrs))
(if (not (eq? (->bool word-offset)
(->bool word-length)))
- (parse-error errtxt "either both or neither of word-offset,word-length can be specified"))
+ (parse-error context "either both or neither of word-offset,word-length can be specified"))
(if (keep-isa-atlist? atlist #f)
(let ((isa (current-isa-lookup (car isas)))
(word-offset (and word-offset
- (parse-number errtxt word-offset '(0 . 256))))
+ (parse-number context word-offset '(0 . 256))))
(word-length (and word-length
- (parse-number errtxt word-length '(0 . 128))))
+ (parse-number context word-length '(0 . 128))))
; ??? 0.127 for now
- (start (parse-number errtxt start '(0 . 127)))
+ (start (parse-number context start '(0 . 127)))
; ??? 0.127 for now
- (flength (parse-number errtxt flength '(0 . 127)))
+ (flength (parse-number context flength '(0 . 127)))
(lsb0? (current-arch-insn-lsb0?))
- (mode-obj (parse-mode-name mode errtxt))
- (follows-obj (-ifld-parse-follows errtxt follows))
+ (mode-obj (parse-mode-name context mode))
+ (follows-obj (-ifld-parse-follows context follows))
)
; Calculate the <bitrange> object.
(let ((result
(make <ifield>
name
- (parse-comment comment errtxt)
+ (parse-comment context comment)
atlist
mode-obj
bitrange
- (-ifld-parse-encode errtxt encode)
- (-ifld-parse-decode errtxt decode))))
+ (-ifld-parse-encode context encode)
+ (-ifld-parse-decode context decode))))
(if follows-obj
(ifld-set-follows! result follows-obj))
result)))
; Read an instruction field description.
; This is the main routine for analyzing instruction fields in the .cpu file.
-; ERRTXT is prepended to error messages to provide context.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
; -ifield-parse is invoked to create the <ifield> object.
-(define (-ifield-read errtxt . arg-list)
- (let (; Current ifield elements:
- (name nil)
+(define (-ifield-read context . arg-list)
+ (let (
+ (name #f)
(comment "")
(attrs nil)
(word-offset #f)
(encode #f)
(decode #f)
)
+
; Loop over each element in ARG-LIST, recording what's found.
(let loop ((arg-list arg-list))
(if (null? arg-list)
((follows) (set! follows (cadr arg)))
((encode) (set! encode (cdr arg)))
((decode) (set! decode (cdr arg)))
- (else (parse-error errtxt "invalid ifield arg" arg)))
+ (else (parse-error context "invalid ifield arg" arg)))
(loop (cdr arg-list)))))
; See if encode/decode were specified as "unspecified".
(set! decode #f))
; Now that we've identified the elements, build the object.
- (-ifield-parse errtxt name comment attrs
+ (-ifield-parse context name comment attrs
word-offset word-length start length- follows
- mode encode decode)
- )
+ mode encode decode))
)
; Parse a `follows' spec.
-(define (-ifld-parse-follows errtxt follows)
+(define (-ifld-parse-follows context follows)
(if follows
(let ((follows-obj (current-op-lookup follows)))
(if (not follows-obj)
- (parse-error errtxt "unknown operand to follow" follows))
+ (parse-error context "unknown operand to follow" follows))
follows-obj)
#f)
)
; Do common parts of <ifield> encode/decode processing.
-(define (-ifld-parse-encode-decode errtxt which value)
+(define (-ifld-parse-encode-decode context which value)
(if value
(begin
(if (or (not (list? value))
(not (list? (car value)))
(not (= (length (car value)) 2))
(not (list? (cadr value))))
- (parse-error errtxt
+ (parse-error context
(string-append "bad ifield " which " spec")
value))
(if (or (not (> (length (cadr value)) 2))
(not (mode:lookup (cadr (cadr value)))))
- (parse-error errtxt
+ (parse-error context
(string-append which " expression must have a mode")
value))))
value
; Parse an <ifield> encode spec.
-(define (-ifld-parse-encode errtxt encode)
- (-ifld-parse-encode-decode errtxt "encode" encode)
+(define (-ifld-parse-encode context encode)
+ (-ifld-parse-encode-decode context "encode" encode)
)
; Parse an <ifield> decode spec.
-(define (-ifld-parse-decode errtxt decode)
- (-ifld-parse-encode-decode errtxt "decode" decode)
+(define (-ifld-parse-decode context decode)
+ (-ifld-parse-encode-decode context "decode" decode)
)
; Define an instruction field object, name/value pair list version.
(define define-ifield
(lambda arg-list
- (let ((f (apply -ifield-read (cons "define-ifield" arg-list))))
+ (let ((f (apply -ifield-read (cons (make-current-context "define-ifield")
+ arg-list))))
(if f
(current-ifld-add! f))
f))
; FIXME: Eventually this should be fixed to take *all* arguments.
(define (define-full-ifield name comment attrs start length mode encode decode)
- (let ((f (-ifield-parse "define-full-ifield" name comment attrs
+ (let ((f (-ifield-parse (make-current-context "define-full-ifield")
+ name comment attrs
#f #f start length #f mode encode decode)))
(if f
(current-ifld-add! f))
; All arguments are in raw (non-evaluated) form.
; The result is the parsed object or #f if object isn't for selected mach(s).
-(define (-multi-ifield-parse errtxt name comment attrs mode
+(define (-multi-ifield-parse context name comment attrs mode
subfields insert extract encode decode)
(logit 2 "Processing multi-ifield element " name " ...\n")
(if (null? subfields)
- (parse-error errtxt "empty subfield list" subfields))
+ (parse-error context "empty subfield list" subfields))
- (let* ((name (parse-name name errtxt))
- (atlist (atlist-parse attrs "cgen_ifld" errtxt))
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name))
+ (atlist (atlist-parse context attrs "cgen_ifld"))
(isas (bitset-attr->list (atlist-attr-value atlist 'ISA #f))))
; No longer ensure only one isa specified.
- ; (if (!= (length isas) 1)
- ; (parse-error errtxt "can only specify 1 isa" attrs))
+ ; (if (!= (length isas) 1)
+ ; (parse-error context "can only specify 1 isa" attrs))
(if (keep-isa-atlist? atlist #f)
+
(begin
(let ((result (new <multi-ifield>))
(subfields (map (lambda (subfld)
(let ((f (current-ifld-lookup subfld)))
(if (not f)
- (parse-error errtxt "unknown ifield" subfld))
+ (parse-error context "unknown ifield"
+ subfld))
f))
subfields)))
(elm-xset! result 'name name)
- (elm-xset! result 'comment (parse-comment comment errtxt))
- ; multi-ifields are always VIRTUAL
+ (elm-xset! result 'comment (parse-comment context comment))
(elm-xset! result 'attrs
- (atlist-parse (cons 'VIRTUAL attrs) "multi-ifield" errtxt))
- (elm-xset! result 'mode (parse-mode-name mode errtxt))
- (elm-xset! result 'encode (-ifld-parse-encode errtxt encode))
- (elm-xset! result 'decode (-ifld-parse-encode errtxt decode))
+ ;; multi-ifields are always VIRTUAL
+ (atlist-parse context (cons 'VIRTUAL attrs)
+ "multi-ifield"))
+ (elm-xset! result 'mode (parse-mode-name context mode))
+ (elm-xset! result 'encode (-ifld-parse-encode context encode))
+ (elm-xset! result 'decode (-ifld-parse-encode context decode))
(if insert
(elm-xset! result 'insert insert)
(elm-xset! result 'insert
(-multi-ifield-make-default-extract name subfields)))
(elm-xset! result 'subfields subfields)
result))
+
; else don't keep isa
#f))
)
; Read an instruction multi-ifield.
+; This is the main routine for analyzing multi-ifields in the .cpu file.
+; CONTEXT is a <context> object for error messages.
+; ARG-LIST is an associative list of field name and field value.
+; -multi-ifield-parse is invoked to create the `multi-ifield' object.
-(define (-multi-ifield-read errtxt . arg-list)
- (let (; Current multi-ifield elements:
+(define (-multi-ifield-read context . arg-list)
+ (let (
(name nil)
(comment "")
(attrs nil)
(encode #f)
(decode #f)
)
+
; Loop over each element in ARG-LIST, recording what's found.
(let loop ((arg-list arg-list))
(if (null? arg-list)
((extract) (set! extract (cadr arg)))
((encode) (set! encode (cdr arg)))
((decode) (set! decode (cdr arg)))
- (else (parse-error errtxt "invalid ifield arg" arg)))
+ (else (parse-error context "invalid ifield arg" arg)))
(loop (cdr arg-list)))))
+
; Now that we've identified the elements, build the object.
- (-multi-ifield-parse errtxt name comment attrs mode subflds
- insert extract encode decode)
- )
+ (-multi-ifield-parse context name comment attrs mode subflds
+ insert extract encode decode))
)
; Define an instruction multi-field object, name/value pair list version.
(define define-multi-ifield
(lambda arg-list
- (let ((f (apply -multi-ifield-read (cons "define-multi-ifield" arg-list))))
+ (let ((f (apply -multi-ifield-read (cons (make-current-context "define-multi-ifield")
+ arg-list))))
(if f
(current-ifld-add! f))
f))
; FIXME: encode/decode arguments are missing.
(define (define-full-multi-ifield name comment attrs mode subflds insert extract)
- (let ((f (-multi-ifield-parse "define-full-multi-ifield" name comment attrs
+ (let ((f (-multi-ifield-parse (make-current-context "define-full-multi-ifield")
+ name comment attrs
mode subflds insert extract #f #f)))
(current-ifld-add! f)
f)
nil)
)
-
(method-make!
<derived-ifield> 'needed-iflds
(lambda (self)
(elm-get self 'subfields)))
)
-
(method-make!
<derived-ifield> 'make!
(lambda (self name comment attrs owner subfields)
; All arguments are in raw (non-evaluated) form.
; The result is the parsed object or #f if insn isn't for selected mach(s).
-(define (-insn-parse errtxt name comment attrs syntax fmt ifield-assertion
+(define (-insn-parse context name comment attrs syntax fmt ifield-assertion
semantics timing)
(logit 2 "Processing insn " name " ...\n")
- (let ((name (parse-name name errtxt))
- (atlist-obj (atlist-parse attrs "cgen_insn" errtxt)))
+ ;; Pick out name first to augment the error context.
+ (let ((name (parse-name context name))
+ (context (context-append-name context name))
+ (atlist-obj (atlist-parse context attrs "cgen_insn")))
(if (keep-atlist? atlist-obj #f)
(semantics (if (not (null? semantics))
semantics
#f))
- (format (-parse-insn-format (string-append errtxt " format")
+ (format (-parse-insn-format (context-append context " format")
fmt))
- (comment (parse-comment comment errtxt))
+ (comment (parse-comment context comment))
; If there are no semantics, mark this as an alias.
; ??? Not sure this makes sense for multi-insns.
(atlist-obj (if semantics
atlist-obj
(atlist-cons (bool-attr-make 'ALIAS #t)
atlist-obj)))
- (syntax (parse-syntax syntax errtxt))
- (timing (parse-insn-timing errtxt timing))
+ (syntax (parse-syntax context syntax))
+ (timing (parse-insn-timing context timing))
)
(if (anyof-operand-format? format)
; 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.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
; -insn-parse is invoked to create the <insn> object.
-(define (insn-read errtxt . arg-list)
- (let ((name nil)
+(define (insn-read context . arg-list)
+ (let (
+ (name nil)
(comment "")
(attrs nil)
(syntax nil)
(semantics nil)
(timing nil)
)
+
; Loop over each element in ARG-LIST, recording what's found.
(let loop ((arg-list arg-list))
(if (null? arg-list)
((ifield-assertion) (set! ifield-assertion (cadr arg)))
((semantics) (set! semantics (cadr arg)))
((timing) (set! timing (cdr arg)))
- (else (parse-error errtxt "invalid insn arg" arg)))
+ (else (parse-error context "invalid insn arg" arg)))
(loop (cdr arg-list)))))
+
; Now that we've identified the elements, build the object.
- (-insn-parse errtxt name comment attrs syntax fmt ifield-assertion
- semantics timing)
- )
+ (-insn-parse context name comment attrs syntax fmt ifield-assertion
+ semantics timing))
)
; Define an instruction object, name/value pair list version.
(define define-insn
(lambda arg-list
- (let ((i (apply insn-read (cons "define-insn" arg-list))))
+ (let ((i (apply insn-read (cons (make-current-context "define-insn")
+ arg-list))))
(if i
(current-insn-add! i))
i))
(define (define-full-insn name comment attrs syntax fmt ifield-assertion
semantics timing)
- (let ((i (-insn-parse "define-full-insn" name comment attrs
+ (let ((i (-insn-parse (make-current-context "define-full-insn")
+ name comment attrs
syntax fmt ifield-assertion
semantics timing)))
(if i
; in turn be a list of strings.
; ??? Not sure this extra flexibility is worth it yet.
-(define (parse-syntax syntax errtxt)
+(define (parse-syntax context syntax)
(cond ((list? syntax)
- (string-map (lambda (elm) (parse-syntax elm errtxt)) syntax))
+ (string-map (lambda (elm) (parse-syntax context elm)) syntax))
((or (string? syntax) (symbol? syntax))
syntax)
- (else (parse-error errtxt "improper syntax" syntax)))
+ (else (parse-error context "improper syntax" syntax)))
)
; Subroutine of -parse-insn-format to parse a symbol ifield spec.
-(define (-parse-insn-format-symbol errtxt sym)
+(define (-parse-insn-format-symbol context sym)
;(debug-repl-env sym)
(let ((op (current-op-lookup sym)))
(if op
(let ((e (ienum-lookup-val sym)))
(if e
(ifld-new-value (ienum:fld (cdr e)) (car e))
- (parse-error errtxt "bad format element, expecting symbol to be operand or insn enum" sym)))))
+ (parse-error context "bad format element, expecting symbol to be operand or insn enum" sym)))))
)
; Subroutine of -parse-insn-format to parse an (ifield-name value) ifield spec.
;
; ??? Error messages need improvement, but that's generally true of cgen.
-(define (-parse-insn-format-ifield-spec errtxt ifld ifld-spec)
+(define (-parse-insn-format-ifield-spec context ifld ifld-spec)
(if (!= (length ifld-spec) 2)
- (parse-error errtxt "bad ifield format, should be (ifield-name value)" ifld-spec))
+ (parse-error context "bad ifield format, should be (ifield-name value)" ifld-spec))
(let ((value (cadr ifld-spec)))
; ??? This use to allow (ifield-name operand-name). That's how
((symbol? value)
(let ((e (enum-lookup-val value)))
(if (not e)
- (parse-error errtxt "symbolic ifield value not an enum" ifld-spec))
+ (parse-error context "symbolic ifield value not an enum" ifld-spec))
(ifld-new-value ifld (car e))))
(else
- (parse-error errtxt "ifield value not an integer or enum" ifld-spec))))
+ (parse-error context "ifield value not an integer or enum" ifld-spec))))
)
; Subroutine of -parse-insn-format to parse an
; ??? There is room for growth in the specification syntax here.
; Possibilities are (ifield-name|operand-name [options] [value]).
-(define (-parse-insn-format-list errtxt spec)
+(define (-parse-insn-format-list context spec)
(let ((ifld (current-ifld-lookup (car spec))))
(if ifld
- (-parse-insn-format-ifield-spec errtxt ifld spec)
- (parse-error errtxt "unknown ifield" spec)))
+ (-parse-insn-format-ifield-spec context ifld spec)
+ (parse-error context "unknown ifield" spec)))
)
; Given an insn format field from a .cpu file, replace it with a list of
; It's called for each instruction, and is one of the more expensive routines
; in insn parsing.
-(define (-parse-insn-format errtxt fld-list)
+(define (-parse-insn-format context fld-list)
(if (null? fld-list)
nil ; field list unspecified
(case (car fld-list)
(string->symbol fld)
fld)))
(cond ((symbol? f)
- (-parse-insn-format-symbol errtxt f))
+ (-parse-insn-format-symbol context f))
((and (list? f)
; ??? This use to allow <ifield> objects
; in the `car' position. Checked for below.
(symbol? (car f)))
- (-parse-insn-format-list errtxt f))
+ (-parse-insn-format-list context f))
(else
(if (and (list? f)
(ifield? (car f)))
- (parse-error errtxt "FIXME: <ifield> object in format spec"))
- (parse-error errtxt "bad format element, neither symbol nor ifield spec" f)))))
+ (parse-error context "FIXME: <ifield> object in format spec" f))
+ (parse-error context "bad format element, neither symbol nor ifield spec" f)))))
(cdr fld-list)))
((=) (begin
(if (or (!= (length fld-list) 2)
(not (symbol? (cadr fld-list))))
- (parse-error errtxt
+ (parse-error context
"bad `=' format spec, should be `(= insn-name)'"
fld-list))
(let ((insn (current-insn-lookup (cadr fld-list))))
(if (not insn)
- (parse-error errtxt "unknown insn" (cadr fld-list)))
+ (parse-error context "unknown insn" (cadr fld-list)))
(insn-iflds insn))))
(else
- (parse-error errtxt "format must begin with `+' or `='" fld-list))
+ (parse-error context "format must begin with `+' or `='" fld-list))
))
)
; Parse an alignment spec.
-(define (-arch-parse-alignment errtxt alignment)
+(define (-arch-parse-alignment context alignment)
(if (memq alignment '(aligned unaligned forced))
alignment
- (parse-error errtxt "invalid alignment" alignment))
+ (parse-error context "invalid alignment" alignment))
)
; Parse an arch mach spec.
; The value is a list of mach names or (mach-name sanitize-key) elements.
; The result is a list of (mach-name . sanitize-key) elements.
-(define (-arch-parse-machs errtxt machs)
+(define (-arch-parse-machs context machs)
(for-each (lambda (m)
(if (or (symbol? m)
(and (list? m) (= (length m) 2)
(symbol? (car m)) (symbol? (cadr m))))
#t ; ok
- (parse-error errtxt "bad arch mach spec" m)))
+ (parse-error context "bad arch mach spec" m)))
machs)
(map (lambda (m)
(if (symbol? m)
; The value is a list of isa names or (isa-name sanitize-key) elements.
; The result is a list of (isa-name . sanitize-key) elements.
-(define (-arch-parse-isas errtxt isas)
+(define (-arch-parse-isas context isas)
(for-each (lambda (m)
(if (or (symbol? m)
(and (list? m) (= (length m) 2)
(symbol? (car m)) (symbol? (cadr m))))
#t ; ok
- (parse-error errtxt "bad arch isa spec" m)))
+ (parse-error context "bad arch isa spec" m)))
isas)
(map (lambda (m)
(if (symbol? m)
machs isas)
(logit 2 "Processing arch " name " ...\n")
(make <arch-data>
- (parse-name name context)
- (parse-comment comment context)
- (atlist-parse attrs "arch" context)
+ (parse-name context name)
+ (parse-comment context comment)
+ (atlist-parse context attrs "arch")
(-arch-parse-alignment context default-alignment)
(parse-boolean context insn-lsb0?)
(-arch-parse-machs context machs)
setup-semantics decode-splits)
(logit 2 "Processing isa " name " ...\n")
- (let ((name (parse-name name context)))
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name)))
+
(if (not (memq name (current-arch-isa-name-list)))
(parse-error context "isa name is not present in `define-arch'" name))
; for builtin objects.
(make <isa>
name
- (parse-comment comment context)
- (atlist-parse attrs "isa" context)
- (parse-number (string-append context
- ": default-insn-word-bitsize")
+ (parse-comment context comment)
+ (atlist-parse context attrs "isa")
+ (parse-number (context-append context
+ ": default-insn-word-bitsize")
default-insn-word-bitsize '(8 . 128))
- (parse-number (string-append context
- ": default-insn-bitsize")
+ (parse-number (context-append context
+ ": default-insn-bitsize")
default-insn-bitsize '(8 . 128))
- (parse-number (string-append context
- ": base-insn-bitsize")
+ (parse-number (context-append context
+ ": base-insn-bitsize")
base-insn-bitsize '(8 . 128))
decode-assist
liw-insns
; Read an isa entry.
; ARG-LIST is an associative list of field name and field value.
-(define -isa-read
- (lambda arg-list
- (let ((context "isa-read")
- ; <isa> object members and default values
- (name #f)
- (attrs nil)
- (comment "")
- (base-insn-bitsize #f)
- (default-insn-bitsize #f)
- (default-insn-word-bitsize #f)
- (decode-assist nil)
- (liw-insns 1)
- ; FIXME: Hobbit computes the wrong symbol for `parallel-insns'
- ; in the `case' expression below because there is a local var
- ; of the same name ("__1" gets appended to the symbol name).
- (parallel-insns- 1)
- (condition nil)
- (setup-semantics nil)
- (decode-splits nil)
- )
- (let loop ((arg-list arg-list))
- (if (null? arg-list)
- nil
- (let ((arg (car arg-list))
- (elm-name (caar arg-list)))
- (case elm-name
- ((name) (set! name (cadr arg)))
- ((comment) (set! comment (cadr arg)))
- ((attrs) (set! attrs (cdr arg)))
- ((default-insn-word-bitsize)
- (set! default-insn-word-bitsize (cadr arg)))
- ((default-insn-bitsize) (set! default-insn-bitsize (cadr arg)))
- ((base-insn-bitsize) (set! base-insn-bitsize (cadr arg)))
- ((decode-assist) (set! decode-assist (cadr arg)))
- ((liw-insns) (set! liw-insns (cadr arg)))
- ((parallel-insns) (set! parallel-insns- (cadr arg)))
- ((condition) (set! condition (cdr arg)))
- ((setup-semantics) (set! setup-semantics (cadr arg)))
- ((decode-splits) (set! decode-splits (cdr arg)))
- ((insn-types) #t) ; ignore for now
- ((frame) #t) ; ignore for now
- (else (parse-error context "invalid isa arg" arg)))
- (loop (cdr arg-list)))))
- ; Now that we've identified the elements, build the object.
- (-isa-parse context name comment attrs
- base-insn-bitsize
- (if default-insn-word-bitsize
- default-insn-word-bitsize
- base-insn-bitsize)
- (if default-insn-bitsize
- default-insn-bitsize
- base-insn-bitsize)
- decode-assist liw-insns parallel-insns- condition
- setup-semantics decode-splits)
- )
- )
+(define (-isa-read context . arg-list)
+ (let (
+ (name #f)
+ (attrs nil)
+ (comment "")
+ (base-insn-bitsize #f)
+ (default-insn-bitsize #f)
+ (default-insn-word-bitsize #f)
+ (decode-assist nil)
+ (liw-insns 1)
+ ;; FIXME: Hobbit computes the wrong symbol for `parallel-insns'
+ ;; in the `case' expression below because there is a local var
+ ;; of the same name ("__1" gets appended to the symbol name).
+ (parallel-insns- 1)
+ (condition nil)
+ (setup-semantics nil)
+ (decode-splits nil)
+ )
+
+ (let loop ((arg-list arg-list))
+ (if (null? arg-list)
+ nil
+ (let ((arg (car arg-list))
+ (elm-name (caar arg-list)))
+ (case elm-name
+ ((name) (set! name (cadr arg)))
+ ((comment) (set! comment (cadr arg)))
+ ((attrs) (set! attrs (cdr arg)))
+ ((default-insn-word-bitsize)
+ (set! default-insn-word-bitsize (cadr arg)))
+ ((default-insn-bitsize) (set! default-insn-bitsize (cadr arg)))
+ ((base-insn-bitsize) (set! base-insn-bitsize (cadr arg)))
+ ((decode-assist) (set! decode-assist (cadr arg)))
+ ((liw-insns) (set! liw-insns (cadr arg)))
+ ((parallel-insns) (set! parallel-insns- (cadr arg)))
+ ((condition) (set! condition (cdr arg)))
+ ((setup-semantics) (set! setup-semantics (cadr arg)))
+ ((decode-splits) (set! decode-splits (cdr arg)))
+ ((insn-types) #t) ; ignore for now
+ ((frame) #t) ; ignore for now
+ (else (parse-error context "invalid isa arg" arg)))
+ (loop (cdr arg-list)))))
+
+ ;; Now that we've identified the elements, build the object.
+ (-isa-parse context name comment attrs
+ base-insn-bitsize
+ (if default-insn-word-bitsize
+ default-insn-word-bitsize
+ base-insn-bitsize)
+ (if default-insn-bitsize
+ default-insn-bitsize
+ base-insn-bitsize)
+ decode-assist liw-insns parallel-insns- condition
+ setup-semantics decode-splits))
)
; Define a <isa> object, name/value pair list version.
(define define-isa
(lambda arg-list
- (let ((i (apply -isa-read arg-list)))
+ (let ((i (apply -isa-read (cons (make-current-context "define-isa")
+ arg-list))))
(if i
(current-isa-add! i))
i))
(define modify-isa
(lambda arg-list
- (let ((errtxt "modify-isa")
+ (let ((context (make-current-context "modify-isa"))
(isa-spec (assq 'name arg-list)))
(if (not isa-spec)
- (parse-error errtxt "isa name not specified"))
+ (parse-error context "isa name not specified"))
- (let ((isa (current-isa-lookup (arg-list-symbol-arg errtxt isa-spec))))
+ (let ((isa (current-isa-lookup (arg-list-symbol-arg context isa-spec))))
(if (not isa)
- (parse-error errtxt "undefined isa" isa-spec))
+ (parse-error context "undefined isa" isa-spec))
(let loop ((args arg-list))
(if (null? args)
(case (car arg-spec)
((name) #f) ; ignore, already processed
((add-decode-split)
- (-isa-add-decode-split! errtxt isa (cdr arg-spec)))
+ (-isa-add-decode-split! context isa (cdr arg-spec)))
(else
- (parse-error errtxt "invalid/unsupported option" (car arg-spec))))
+ (parse-error context "invalid/unsupported option" (car arg-spec))))
(loop (cdr args)))))))
*UNSPECIFIED*)
; description in the .cpu file.
; All arguments are in raw (non-evaluated) form.
-(define (-cpu-parse name comment attrs
+(define (-cpu-parse context name comment attrs
endian insn-endian data-endian float-endian
word-bitsize insn-chunk-bitsize file-transform parallel-insns)
(logit 2 "Processing cpu family " name " ...\n")
- ; Pick out name first 'cus we need it as a string(/symbol).
- (let* ((name (parse-name name "cpu"))
- (errtxt (stringsym-append "cpu " name)))
+
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name)))
+
(if (keep-cpu? name)
(make <cpu>
name
- (parse-comment comment errtxt)
- (atlist-parse attrs "cpu" errtxt)
+ (parse-comment context comment)
+ (atlist-parse context attrs "cpu")
endian insn-endian data-endian float-endian
word-bitsize
insn-chunk-bitsize
; Read a cpu family description
; This is the main routine for analyzing a cpu description in the .cpu file.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
; -cpu-parse is invoked to create the <cpu> object.
-(define -cpu-read
- (lambda arg-list
- (let ((errtxt "cpu-read")
- ; <cpu> object members and default values
- (name nil)
- (comment nil)
- (attrs nil)
- (endian #f)
- (insn-endian #f)
- (data-endian #f)
- (float-endian #f)
- (word-bitsize #f)
- (insn-chunk-bitsize 0)
- (file-transform "")
- ; FIXME: Hobbit computes the wrong symbol for `parallel-insns'
- ; in the `case' expression below because there is a local var
- ; of the same name ("__1" gets appended to the symbol name).
- (parallel-insns- #f)
- )
- ; Loop over each element in ARG-LIST, recording what's found.
- (let loop ((arg-list arg-list))
- (if (null? arg-list)
- nil
- (let ((arg (car arg-list))
- (elm-name (caar arg-list)))
- (case elm-name
- ((name) (set! name (cadr arg)))
- ((comment) (set! comment (cadr arg)))
- ((attrs) (set! attrs (cdr arg)))
- ((endian) (set! endian (cadr arg)))
- ((insn-endian) (set! insn-endian (cadr arg)))
- ((data-endian) (set! data-endian (cadr arg)))
- ((float-endian) (set! float-endian (cadr arg)))
- ((word-bitsize) (set! word-bitsize (cadr arg)))
- ((insn-chunk-bitsize) (set! insn-chunk-bitsize (cadr arg)))
- ((file-transform) (set! file-transform (cadr arg)))
- ((parallel-insns) (set! parallel-insns- (cadr arg)))
- (else (parse-error errtxt "invalid cpu arg" arg)))
- (loop (cdr arg-list)))))
- ; Now that we've identified the elements, build the object.
- (-cpu-parse name comment attrs
- endian insn-endian data-endian float-endian
- word-bitsize insn-chunk-bitsize file-transform parallel-insns-)
- )
- )
+(define (-cpu-read context . arg-list)
+ (let (
+ (name nil)
+ (comment nil)
+ (attrs nil)
+ (endian #f)
+ (insn-endian #f)
+ (data-endian #f)
+ (float-endian #f)
+ (word-bitsize #f)
+ (insn-chunk-bitsize 0)
+ (file-transform "")
+ ;; FIXME: Hobbit computes the wrong symbol for `parallel-insns'
+ ;; in the `case' expression below because there is a local var
+ ;; of the same name ("__1" gets appended to the symbol name).
+ (parallel-insns- #f)
+ )
+
+ ;; Loop over each element in ARG-LIST, recording what's found.
+ (let loop ((arg-list arg-list))
+ (if (null? arg-list)
+ nil
+ (let ((arg (car arg-list))
+ (elm-name (caar arg-list)))
+ (case elm-name
+ ((name) (set! name (cadr arg)))
+ ((comment) (set! comment (cadr arg)))
+ ((attrs) (set! attrs (cdr arg)))
+ ((endian) (set! endian (cadr arg)))
+ ((insn-endian) (set! insn-endian (cadr arg)))
+ ((data-endian) (set! data-endian (cadr arg)))
+ ((float-endian) (set! float-endian (cadr arg)))
+ ((word-bitsize) (set! word-bitsize (cadr arg)))
+ ((insn-chunk-bitsize) (set! insn-chunk-bitsize (cadr arg)))
+ ((file-transform) (set! file-transform (cadr arg)))
+ ((parallel-insns) (set! parallel-insns- (cadr arg)))
+ (else (parse-error context "invalid cpu arg" arg)))
+ (loop (cdr arg-list)))))
+
+ ;; Now that we've identified the elements, build the object.
+ (-cpu-parse context name comment attrs
+ endian insn-endian data-endian float-endian
+ word-bitsize insn-chunk-bitsize file-transform parallel-insns-))
)
; Define a cpu family object, name/value pair list version.
(define define-cpu
(lambda arg-list
- (let ((c (apply -cpu-read arg-list)))
+ (let ((c (apply -cpu-read (cons (make-current-context "define-cpu")
+ arg-list))))
(if c
(begin
(current-cpu-add! c)
(define (-mach-parse context name comment attrs cpu bfd-name isas)
(logit 2 "Processing mach " name " ...\n")
- (let ((name (parse-name name context)))
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name)))
+
(if (not (list? isas))
(parse-error context "isa spec not a list" isas))
(let ((cpu-obj (current-cpu-lookup cpu))
(parse-error context "unknown isa in" isas))
(if (not (string? bfd-name))
(parse-error context "bfd-name not a string" bfd-name))
+
(if (keep-mach? (list name))
+
(make <mach>
name
- (parse-comment comment context)
- (atlist-parse attrs "mach" context)
+ (parse-comment context comment)
+ (atlist-parse context attrs "mach")
cpu-obj
bfd-name
isa-list)
+
(begin
(logit 2 "Ignoring " name ".\n")
#f)))) ; mach is not to be kept
)
; Read a mach entry.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-(define -mach-read
- (lambda arg-list
- (let ((context "mach-read")
- (name nil)
- (attrs nil)
- (comment nil)
- (cpu nil)
- (bfd-name #f)
- (isas #f)
- )
- (let loop ((arg-list arg-list))
- (if (null? arg-list)
- nil
- (let ((arg (car arg-list))
- (elm-name (caar arg-list)))
- (case elm-name
- ((name) (set! name (cadr arg)))
- ((comment) (set! comment (cadr arg)))
- ((attrs) (set! attrs (cdr arg)))
- ((cpu) (set! cpu (cadr arg)))
- ((bfd-name) (set! bfd-name (cadr arg)))
- ((isas) (set! isas (cdr arg)))
- (else (parse-error context "invalid mach arg" arg)))
- (loop (cdr arg-list)))))
- ; Now that we've identified the elements, build the object.
- (-mach-parse context name comment attrs cpu
- ; Default bfd-name is same as object's name.
- (if bfd-name bfd-name (symbol->string name))
- ; Default isa is the first one.
- (if isas isas (list (obj:name (car (current-isa-list))))))
- )
- )
+(define (-mach-read context . arg-list)
+ (let (
+ (name nil)
+ (attrs nil)
+ (comment nil)
+ (cpu nil)
+ (bfd-name #f)
+ (isas #f)
+ )
+
+ (let loop ((arg-list arg-list))
+ (if (null? arg-list)
+ nil
+ (let ((arg (car arg-list))
+ (elm-name (caar arg-list)))
+ (case elm-name
+ ((name) (set! name (cadr arg)))
+ ((comment) (set! comment (cadr arg)))
+ ((attrs) (set! attrs (cdr arg)))
+ ((cpu) (set! cpu (cadr arg)))
+ ((bfd-name) (set! bfd-name (cadr arg)))
+ ((isas) (set! isas (cdr arg)))
+ (else (parse-error context "invalid mach arg" arg)))
+ (loop (cdr arg-list)))))
+
+ ;; Now that we've identified the elements, build the object.
+ (-mach-parse context name comment attrs cpu
+ ;; Default bfd-name is same as object's name.
+ (if bfd-name bfd-name (symbol->string name))
+ ;; Default isa is the first one.
+ (if isas isas (list (obj:name (car (current-isa-list)))))))
)
; Define a <mach> object, name/value pair list version.
(define define-mach
(lambda arg-list
- (let ((m (apply -mach-read arg-list)))
+ (let ((m (apply -mach-read (cons (make-current-context "define-mach")
+ arg-list))))
(if m
(current-mach-add! m))
m))
; Parse a macro-insn expansion description.
; ??? At present we only support unconditional simple expansion.
-(define (-minsn-parse-expansion errtxt expn)
+(define (-minsn-parse-expansion context expn)
(if (not (form? expn))
- (parse-error errtxt "invalid macro expansion" expn))
+ (parse-error context "invalid macro expansion" expn))
(if (not (eq? 'emit (car expn)))
- (parse-error errtxt "invalid macro expansion, must be `(emit ...)'" expn))
+ (parse-error context "invalid macro expansion, must be `(emit ...)'" expn))
expn
)
\f
; All arguments are in raw (non-evaluated) form.
; The result is the parsed object or #f if object isn't for selected mach(s).
-(define (-minsn-parse errtxt name comment attrs syntax expansions)
+(define (-minsn-parse context name comment attrs syntax expansions)
(logit 2 "Processing macro-insn " name " ...\n")
(if (not (list? expansions))
- (parse-error errtxt "invalid macro expansion list" expansions))
+ (parse-error context "invalid macro expansion list" expansions))
- (let ((name (parse-name name errtxt))
- (atlist-obj (atlist-parse attrs "cgen_minsn" errtxt)))
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name))
+ (atlist-obj (atlist-parse context attrs "cgen_minsn")))
(if (keep-atlist? atlist-obj #f)
(let ((result (make <macro-insn>
name
- (parse-comment comment errtxt)
+ (parse-comment context comment)
atlist-obj
- (parse-syntax syntax errtxt)
- (map (lambda (e) (-minsn-parse-expansion errtxt e))
+ (parse-syntax context syntax)
+ (map (lambda (e) (-minsn-parse-expansion context e))
expansions))))
result)
; Read a macro-insn description
; This is the main routine for analyzing macro-insns in the .cpu file.
-; ERRTXT is prepended to error messages to provide context.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
; -minsn-parse is invoked to create the `macro-insn' object.
-(define (-minsn-read errtxt . arg-list)
- (let (; Current macro-insn elements:
+(define (-minsn-read context . arg-list)
+ (let (
(name nil)
(comment "")
(attrs nil)
(syntax "")
(expansions nil)
)
+
; Loop over each element in ARG-LIST, recording what's found.
(let loop ((arg-list arg-list))
(if (null? arg-list)
((attrs) (set! attrs (cdr arg)))
((syntax) (set! syntax (cadr arg)))
((expansions) (set! expansions (cdr arg)))
- (else (parse-error errtxt "invalid macro-insn arg" arg)))
+ (else (parse-error context "invalid macro-insn arg" arg)))
(loop (cdr arg-list)))))
+
; Now that we've identified the elements, build the object.
- (-minsn-parse errtxt name comment attrs syntax expansions)
- )
+ (-minsn-parse context name comment attrs syntax expansions))
)
; Define a macro-insn object, name/value pair list version.
(lambda arg-list
(if (eq? APPLICATION 'SIMULATOR)
#f ; don't waste time if simulator
- (let ((m (apply -minsn-read (cons "define-minsn" arg-list))))
+ (let ((m (apply -minsn-read (cons (make-current-context "define-minsn")
+ arg-list))))
(if m
(current-minsn-add! m))
m)))
(define (define-full-minsn name comment attrs syntax expansion)
(if (eq? APPLICATION 'SIMULATOR)
#f ; don't waste time if simulator
- (let ((m (-minsn-parse "define-full-minsn" name comment
+ (let ((m (-minsn-parse (make-current-context "define-full-minsn")
+ name comment
(cons 'ALIAS attrs)
syntax (list expansion))))
(if m
; This involves making a copy of REAL-INSN's ifield list and assigning
; known quantities to operands that have fixed values in the macro-insn.
-(define (minsn-compute-iflds errtxt minsn-iflds real-insn)
+(define (-minsn-compute-iflds context minsn-iflds real-insn)
(let* ((iflds (list-copy (insn-iflds real-insn)))
; List of "free variables", i.e. operands.
(ifld-ops (find ifld-operand? iflds))
(ifld-pair (object-memq f-name iflds)))
;(logit 3 "Processing ifield " f-name " ...\n")
(if (not ifld-pair)
- (parse-error errtxt "unknown operand" f))
+ (parse-error context "unknown operand" f))
; Ensure `f' is an operand.
(if (not (memq f-name ifld-names))
- (parse-error errtxt "not an operand" f))
+ (parse-error context "not an operand" f))
(if (pair? f)
(set-car! ifld-pair (ifld-new-value (car ifld-pair) (cadr f))))
(delq! f-name ifld-names)))
minsn-iflds)
(if (not (equal? ifld-names '(#f)))
- (parse-error errtxt "incomplete operand list, missing: " (cdr ifld-names)))
+ (parse-error context "incomplete operand list, missing: " (cdr ifld-names)))
iflds)
)
; Create an aliased real insn from an alias macro-insn.
-(define (minsn-make-alias errtxt minsn)
+(define (minsn-make-alias context minsn)
(if (or (not (has-attr? minsn 'ALIAS))
; Must emit exactly one real insn.
(not (eq? 'emit (caar (minsn-expansions minsn)))))
- (parse-error errtxt "not an alias macro-insn" minsn))
+ (parse-error context "not an alias macro-insn" minsn))
(let* ((expn (car (minsn-expansions minsn)))
(alias-of (current-insn-lookup (cadr expn))))
(if (not alias-of)
- (parse-error errtxt "unknown real insn in expansion" minsn))
+ (parse-error context "unknown real insn in expansion" minsn))
(let ((i (make <insn>
(obj:name minsn)
(obj:comment minsn)
(obj-atlist minsn)
(minsn-syntax minsn)
- (minsn-compute-iflds (string-append errtxt
- ": " (obj:str-name minsn))
- (cddr expn) alias-of)
+ (-minsn-compute-iflds (context-append context
+ (string-append ": " (obj:str-name minsn)))
+ (cddr expn) alias-of)
#f ; ifield-assertion
#f ; semantics
#f ; timing
; This is the main routine for building a mode object.
; All arguments are in raw (non-evaluated) form.
-(define (-mode-parse errtxt name comment attrs class bits bytes
- non-mode-c-type printf-type sem-mode ptr-to host?)
+(define (-mode-parse context name comment attrs class bits bytes
+ non-mode-c-type printf-type sem-mode ptr-to host?)
(logit 2 "Processing mode " name " ...\n")
- (let* ((name (parse-name name errtxt))
- (errtxt (stringsym-append errtxt " " name))
- (result (make <mode>
- name
- (parse-comment comment errtxt)
- (atlist-parse attrs "mode" errtxt)
- class bits bytes non-mode-c-type printf-type
- sem-mode ptr-to host?)))
- result)
+
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name)))
+
+ (make <mode>
+ name
+ (parse-comment context comment)
+ (atlist-parse context attrs "mode")
+ class bits bytes non-mode-c-type printf-type
+ sem-mode ptr-to host?))
)
; ??? At present there is no define-mode that takes an associative list
(define (define-full-mode name comment attrs class bits bytes
non-mode-c-type printf-type sem-mode ptr-to host?)
- (let ((m (-mode-parse "define-full-mode" name comment attrs
+ (let ((m (-mode-parse (make-current-context "define-full-mode")
+ name comment attrs
class bits bytes
non-mode-c-type printf-type sem-mode ptr-to host?)))
; Add it to the list of insn modes.
)
; Parse MODE-NAME and return the mode object.
+; CONTEXT is a <context> object for error messages.
; An error is signalled if MODE isn't valid.
-(define (parse-mode-name mode-name errtxt)
+(define (parse-mode-name context mode-name)
(let ((m (mode:lookup mode-name)))
- (if (not m) (parse-error errtxt "not a valid mode" mode-name))
+ (if (not m)
+ (parse-error context "not a valid mode" mode-name))
m)
)
\f
; Parse a `prefetch' spec.
-(define (-prefetch-parse errtxt expr)
+(define (-prefetch-parse context expr)
nil
)
; Parse a `retire' spec.
-(define (-retire-parse errtxt expr)
+(define (-retire-parse context expr)
nil
)
; ??? Perhaps we should also use name/value pairs here, but that's an
; unnecessary complication at this point in time.
-(define (-pipeline-parse errtxt model-name spec) ; name comments attrs elements)
+(define (-pipeline-parse context model-name spec) ; name comments attrs elements)
(if (not (= (length spec) 4))
- (parse-error errtxt "pipeline spec not `name comment attrs elements'" spec))
+ (parse-error context "pipeline spec not `name comment attrs elements'" spec))
(apply make (cons <pipeline> spec))
)
; ??? Perhaps we should also use name/value pairs here, but that's an
; unnecessary complication at this point in time.
-(define (-unit-parse errtxt model-name spec) ; name comments attrs elements)
+(define (-unit-parse context model-name spec) ; name comments attrs elements)
(if (not (= (length spec) 9))
- (parse-error errtxt "unit spec not `name comment attrs issue done state inputs outputs profile'" spec))
+ (parse-error context "unit spec not `name comment attrs issue done state inputs outputs profile'" spec))
(apply make (append (cons <unit> spec) (list model-name)))
)
\f
; description in the .cpu file.
; All arguments are in raw (non-evaluated) form.
-(define (-model-parse errtxt name comment attrs mach-name prefetch retire pipelines state units)
+(define (-model-parse context name comment attrs mach-name prefetch retire pipelines state units)
(logit 2 "Processing model " name " ...\n")
- (let ((name (parse-name name errtxt))
- ; FIXME: switch to `context' like in cver.
- (errtxt (stringsym-append errtxt " " name))
- (mach (current-mach-lookup mach-name)))
+
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name))
+ (mach (current-mach-lookup mach-name)))
+
(if (null? units)
- (parse-error errtxt "there must be at least one function unit" name))
+ (parse-error context "there must be at least one function unit" name))
+
(if mach ; is `mach' being "kept"?
(let ((model-obj
(make <model>
name
- (parse-comment comment errtxt)
- (atlist-parse attrs "cpu" errtxt)
+ (parse-comment context comment)
+ (atlist-parse context attrs "cpu")
mach
- (-prefetch-parse errtxt prefetch)
- (-retire-parse errtxt retire)
- (map (lambda (p) (-pipeline-parse errtxt name p)) pipelines)
+ (-prefetch-parse context prefetch)
+ (-retire-parse context retire)
+ (map (lambda (p) (-pipeline-parse context name p)) pipelines)
state
- (map (lambda (u) (-unit-parse errtxt name u)) units))))
+ (map (lambda (u) (-unit-parse context name u)) units))))
model-obj)
+
(begin
; MACH wasn't found, ignore this model.
(logit 2 "Nonexistant mach " mach-name ", ignoring " name ".\n")
; Read a model description.
; This is the main routine for analyzing models in the .cpu file.
-; ERRTXT is prepended to error messages to provide context.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
; -model-parse is invoked to create the `model' object.
-(define (-model-read errtxt . arg-list)
- (let (; Current mach elements:
+(define (-model-read context . arg-list)
+ (let (
(name nil) ; name of model
(comment nil) ; description of model
(attrs nil) ; attributes
(state nil) ; list of (name mode) pairs to record state
(units nil) ; list of function units
)
+
(let loop ((arg-list arg-list))
(if (null? arg-list)
nil
((pipeline) (set! pipelines (cons (cdr arg) pipelines)))
((state) (set! state (cdr arg)))
((unit) (set! units (cons (cdr arg) units)))
- (else (parse-error errtxt "invalid model arg" arg)))
+ (else (parse-error context "invalid model arg" arg)))
(loop (cdr arg-list)))))
+
; Now that we've identified the elements, build the object.
- (-model-parse errtxt name comment attrs mach prefetch retire pipelines state units)
- )
+ (-model-parse context name comment attrs mach prefetch retire pipelines state units))
)
; Define a cpu model object, name/value pair list version.
(define define-model
(lambda arg-list
- (let ((m (apply -model-read (cons "define-model" arg-list))))
+ (let ((m (apply -model-read (cons (make-current-context "define-model")
+ arg-list))))
(if m
(current-model-add! m))
m))
; are returned as (model1), i.e. an empty unit list.
(define (parse-insn-timing context insn-timing-desc)
- (logit 3 " parse-insn-timing: context= " context ", desc= " insn-timing-desc "\n")
+ (logit 3 " parse-insn-timing: context= " (context-prefix context)
+ ", desc= " insn-timing-desc "\n")
(map (lambda (model-timing-desc)
(let* ((model-name (car model-timing-desc))
(model (current-model-lookup model-name)))
; Values >= 128 are 128 + the index into the operand table.
(define (compute-syntax strip-mnemonic? strip-mnem-operands? syntax op-macro)
- (let ((context "syntax computation")
+ (let ((context (make-prefix-context "syntax computation"))
(syntax (if strip-mnemonic?
(strip-mnemonic strip-mnem-operands? syntax)
syntax)))
(logit 2 "Generating macro-instruction table ...\n")
(let* ((minsn-list (map (lambda (minsn)
(if (has-attr? minsn 'ALIAS)
- (minsn-make-alias "gen-macro-insn-table" minsn)
+ (minsn-make-alias (make-prefix-context "gen-macro-insn-table")
+ minsn)
minsn))
(current-minsn-list)))
(all-attrs (current-insn-attr-list))
<pc> 'make!
(lambda (self)
(send-next self 'make! 'pc "program counter"
- (atlist-parse '(SEM-ONLY) "cgen_operand" "make! of pc")
+ (atlist-parse (make-prefix-context "make! of pc")
+ '(SEM-ONLY) "cgen_operand")
'h-pc
'DFLT
(make <hw-index> 'anonymous
(!= (length getter) 2)
(not (and (list? (car getter))
(= (length (car getter)) rank))))
- (context-error context
- (string-append "invalid getter, should be "
- (-operand-g/setter-syntax rank #f))
- getter))
+ (parse-error context
+ (string-append "invalid getter, should be "
+ (-operand-g/setter-syntax rank #f))
+ getter))
(if (not (rtx? (cadr getter)))
- (context-error context "invalid rtx expression" getter))
+ (parse-error context "invalid rtx expression" getter))
getter))
)
(!= (length setter) 2)
(not (and (list? (car setter))
(= (+ 1 (length (car setter)) rank)))))
- (context-error context
- (string-append "invalid setter, should be "
- (-operand-g/setter-syntax rank #t))
- setter))
+ (parse-error context
+ (string-append "invalid setter, should be "
+ (-operand-g/setter-syntax rank #t))
+ setter))
(if (not (rtx? (cadr setter)))
- (context-error context "invalid rtx expression" setter))
+ (parse-error context "invalid rtx expression" setter))
setter))
)
; ??? This only takes insn fields as the index. May need another proc (or an
; enhancement of this one) that takes other kinds of indices.
-(define (-operand-parse errtxt name comment attrs hw mode ifld handlers getter setter)
+(define (-operand-parse context name comment attrs hw mode ifld handlers getter setter)
(logit 2 "Processing operand " name " ...\n")
- (let ((name (parse-name name errtxt))
- (atlist-obj (atlist-parse attrs "cgen_operand" errtxt)))
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name))
+ (atlist-obj (atlist-parse context attrs "cgen_operand")))
(if (keep-atlist? atlist-obj #f)
(let ((hw-objs (current-hw-sem-lookup hw))
- (mode-obj (parse-mode-name mode errtxt))
+ (mode-obj (parse-mode-name context mode))
(ifld-val (if (integer? ifld)
ifld
- (current-ifld-lookup ifld)))
- ; FIXME: quick hack
- (context (context-make-reader errtxt)))
+ (current-ifld-lookup ifld))))
(if (not mode-obj)
- (parse-error errtxt "unknown mode" mode))
+ (parse-error context "unknown mode" mode))
(if (not ifld-val)
- (parse-error errtxt "unknown insn field" ifld))
+ (parse-error context "unknown insn field" ifld))
; Disallow some obviously invalid numeric indices.
(if (and (integer? ifld-val)
(< ifld-val 0))
- (parse-error errtxt "invalid integer index" ifld-val))
+ (parse-error context "invalid integer index" ifld-val))
; Don't validate HW until we know whether this operand will be kept
; or not. If not, HW may have been discarded too.
(if (null? hw-objs)
- (parse-error errtxt "unknown hardware element" hw))
+ (parse-error context "unknown hardware element" hw))
; At this point IFLD-VAL is either an integer or an <ifield> object.
; Since we can't look up the hardware element at this time
'ifield 'UINT ifld-val)))))
(make <operand>
name
- (parse-comment comment errtxt)
+ (parse-comment context comment)
; Copy FLD's attributes so one needn't duplicate attrs like
; PCREL-ADDR, etc. An operand inherits the attributes of
; its field. They are overridable of course, which is why we use
hw ; note that this is the hw's name, not an object
mode ; ditto, this is a name, not an object
hw-index
- (parse-handlers errtxt '(parse print) handlers)
+ (parse-handlers context '(parse print) handlers)
(-operand-parse-getter context getter (if scalar? 0 1))
(-operand-parse-setter context setter (if scalar? 0 1))
)))
; Read an operand description.
; This is the main routine for analyzing operands in the .cpu file.
-; ERRTXT is prepended to error messages to provide context.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
; -operand-parse is invoked to create the <operand> object.
-(define (-operand-read errtxt . arg-list)
- (let (; Current operand elements:
+(define (-operand-read context . arg-list)
+ (let (
(name nil)
(comment nil)
(attrs nil)
(getter nil)
(setter nil)
)
+
(let loop ((arg-list arg-list))
(if (null? arg-list)
nil
((handlers) (set! handlers (cdr arg)))
((getter) (set! getter (cdr arg)))
((setter) (set! setter (cdr arg)))
- (else (parse-error errtxt "invalid operand arg" arg)))
+ (else (parse-error context "invalid operand arg" arg)))
(loop (cdr arg-list)))))
+
; Now that we've identified the elements, build the object.
- (-operand-parse errtxt name comment attrs type mode index handlers
- getter setter)
- )
+ (-operand-parse context name comment attrs type mode index handlers
+ getter setter))
)
; Define an operand object, name/value pair list version.
(define define-operand
(lambda arg-list
- (let ((op (apply -operand-read (cons "define-operand" arg-list))))
+ (let ((op (apply -operand-read (cons (make-current-context "define-operand")
+ arg-list))))
(if op
(current-op-add! op))
op))
; Define an operand object, all arguments specified.
(define (define-full-operand name comment attrs type mode index handlers getter setter)
- (let ((op (-operand-parse "define-full-operand" name comment attrs
+ (let ((op (-operand-parse (make-current-context "define-full-operand")
+ name comment attrs
type mode index handlers getter setter)))
(if op
(current-op-add! op))
(define (-derived-parse-encoding context operand-name encoding)
(if (or (null? encoding)
(not (list? encoding)))
- (context-error context "encoding not a list" encoding))
+ (parse-error context "encoding not a list" encoding))
(if (not (eq? (car encoding) '+))
- (context-error context "encoding must begin with `+'" encoding))
+ (parse-error context "encoding must begin with `+'" encoding))
; ??? Calling -parse-insn-format is a quick hack.
; It's an internal routine of some other file.
- (let ((iflds (-parse-insn-format "anyof encoding" encoding)))
+ (let ((iflds (-parse-insn-format context encoding)))
(make <derived-ifield>
operand-name
'derived-ifield ; (string-append "<derived-ifield> for " operand-name)
; ??? Currently no support for handlers(,???) found in normal operands.
; Later, when necessary.
-(define (-derived-operand-parse errtxt name comment attrs mode
+(define (-derived-operand-parse context name comment attrs mode
args syntax
base-ifield encoding ifield-assertion
getter setter)
(logit 2 "Processing derived operand " name " ...\n")
- (let ((name (parse-name name errtxt))
- (atlist-obj (atlist-parse attrs "cgen_operand" errtxt)))
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name))
+ (atlist-obj (atlist-parse context attrs "cgen_operand")))
(if (keep-atlist? atlist-obj #f)
- (let* ((mode-obj (parse-mode-name mode errtxt))
- ; FIXME: quick hack
- (context (context-make-reader errtxt))
- (parsed-encoding (-derived-parse-encoding context name encoding))
- )
+ (let ((mode-obj (parse-mode-name context mode))
+ (parsed-encoding (-derived-parse-encoding context name encoding)))
+
(if (not mode-obj)
- (parse-error errtxt "unknown mode" mode))
+ (parse-error context "unknown mode" mode))
(let ((result
(make <derived-operand>
name
- (parse-comment comment errtxt)
+ (parse-comment context comment)
atlist-obj
mode-obj
(map (lambda (a)
(if (not (symbol? a))
- (parse-error errtxt "arg not a symbol" a))
+ (parse-error context "arg not a symbol" a))
(let ((op (current-op-lookup a)))
(if (not op)
- (parse-error errtxt "not an operand" a))
+ (parse-error context "not an operand" a))
op))
args)
syntax
; Read a derived operand description.
; This is the main routine for analyzing derived operands in the .cpu file.
-; ERRTXT is prepended to error messages to provide context.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
; -derived-operand-parse is invoked to create the <derived-operand> object.
-(define (-derived-operand-read errtxt . arg-list)
- (let (; Current derived-operand elements:
+(define (-derived-operand-read context . arg-list)
+ (let (
(name nil)
(comment nil)
(attrs nil)
(getter nil)
(setter nil)
)
+
(let loop ((arg-list arg-list))
(if (null? arg-list)
nil
((ifield-assertion) (set! ifield-assertion (cadr arg)))
((getter) (set! getter (cadr arg)))
((setter) (set! setter (cadr arg)))
- (else (parse-error errtxt "invalid derived-operand arg" arg)))
+ (else (parse-error context "invalid derived-operand arg" arg)))
(loop (cdr arg-list)))))
+
; Now that we've identified the elements, build the object.
- (-derived-operand-parse errtxt name comment attrs mode args
+ (-derived-operand-parse context name comment attrs mode args
syntax base-ifield encoding ifield-assertion
- getter setter)
- )
+ getter setter))
)
; Define a derived operand object, name/value pair list version.
(define define-derived-operand
(lambda arg-list
(let ((op (apply -derived-operand-read
- (cons "define-derived-operand" arg-list))))
+ (cons (make-current-context "define-derived-operand")
+ arg-list))))
(if op
(current-op-add! op))
op))
; ??? Not supported (yet).
;
;(define (define-full-derived-operand name comment attrs mode ...)
-; (let ((op (-derived-operand-parse "define-full-derived-operand"
+; (let ((op (-derived-operand-parse (make-current-context "define-full-derived-operand")
; name comment attrs
; mode ...)))
; (if op
(define (-anyof-parse-choice context choice)
(if (not (symbol? choice))
- (context-error context "anyof choice not a symbol" choice))
+ (parse-error context "anyof choice not a symbol" choice))
(let ((op (current-op-lookup choice)))
(if (not (derived-operand? op))
- (context-error context "anyof choice not a derived-operand" choice))
+ (parse-error context "anyof choice not a derived-operand" choice))
op)
)
; ??? Currently no support for handlers(,???) found in normal operands.
; Later, when necessary.
-(define (-anyof-operand-parse errtxt name comment attrs mode
+(define (-anyof-operand-parse context name comment attrs mode
base-ifield choices)
(logit 2 "Processing anyof operand " name " ...\n")
- (let ((name (parse-name name errtxt))
- (atlist-obj (atlist-parse attrs "cgen_operand" errtxt)))
+ ;; Pick out name first to augment the error context.
+ (let* ((name (parse-name context name))
+ (context (context-append-name context name))
+ (atlist-obj (atlist-parse context attrs "cgen_operand")))
(if (keep-atlist? atlist-obj #f)
- (let ((mode-obj (parse-mode-name mode errtxt))
- ; FIXME: quick hack
- (context (context-make-reader errtxt)))
+ (let ((mode-obj (parse-mode-name context mode)))
(if (not mode-obj)
- (parse-error errtxt "unknown mode" mode))
+ (parse-error context "unknown mode" mode))
(make <anyof-operand>
name
- (parse-comment comment errtxt)
+ (parse-comment context comment)
atlist-obj
mode
base-ifield
; Read an anyof operand description.
; This is the main routine for analyzing anyof operands in the .cpu file.
-; ERRTXT is prepended to error messages to provide context.
+; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
; -anyof-operand-parse is invoked to create the <anyof-operand> object.
-(define (-anyof-operand-read errtxt . arg-list)
- (let (; Current operand elements:
+(define (-anyof-operand-read context . arg-list)
+ (let (
(name nil)
(comment nil)
(attrs nil)
(base-ifield nil)
(choices nil)
)
+
(let loop ((arg-list arg-list))
(if (null? arg-list)
nil
((mode) (set! mode (cadr arg)))
((base-ifield) (set! base-ifield (cadr arg)))
((choices) (set! choices (cdr arg)))
- (else (parse-error errtxt "invalid anyof-operand arg" arg)))
+ (else (parse-error context "invalid anyof-operand arg" arg)))
(loop (cdr arg-list)))))
+
; Now that we've identified the elements, build the object.
- (-anyof-operand-parse errtxt name comment attrs mode base-ifield choices)
- )
+ (-anyof-operand-parse context name comment attrs mode base-ifield choices))
)
; Define an anyof operand object, name/value pair list version.
(define define-anyof-operand
(lambda arg-list
(let ((op (apply -anyof-operand-read
- (cons "define-anyof-operand" arg-list))))
+ (cons (make-current-context "define-anyof-operand")
+ arg-list))))
(if op
(current-op-add! op))
op))
":")))
)
-; Signal an error while reading a .cpu file.
-
-(define (reader-error msg expr help-text)
- (let* ((loc (current-reader-location))
+;;; Signal a parse error while reading a .cpu file.
+;;; If CONTEXT is #f, use a default context of the current reader location
+;;; and an empty prefix.
+;;; If MAYBE-HELP-TEXT is specified, elide the last trailing \n.
+;;; Multiple lines of help text need embedded newlines, and should be no longer
+;;; than 79 characters.
+
+(define (parse-error context message expr . maybe-help-text)
+ (if (not context)
+ (set! context (make <context> (current-reader-location) #f)))
+ (let* ((loc (context-location context))
(top-sloc (location-top loc))
- (errmsg
- (string-append (single-location->string 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 (location->string loc))))
-)
-
-; Signal a parse error while reading a .cpu file.
-; FIXME: Add expr arg and change args to optional help text.
-
-(define (parse-error errtxt message . args)
- (cond ((null? args)
- (reader-error (string-append errtxt ": " message ":") "" ""))
- ((= (length args) 1)
- (reader-error (string-append errtxt ": " message ":") (car args) ""))
- (else
- (reader-error (string-append errtxt ": " message ":") args "")))
+ (prefix (context-prefix context)))
+ (error
+ (simple-format
+ #f
+ "While reading description:\n~A: ~A:\n ~S\nReference chain:\n~A~A"
+ (single-location->simple-string top-sloc)
+ (if prefix
+ (string-append prefix ": " message)
+ message)
+ expr
+ (location->string loc)
+ (if (null? maybe-help-text)
+ ""
+ (string-append "\n" (car maybe-help-text))))))
)
; Return the current source location.
; Process a macro-expanded entry.
(define (-reader-process-expanded-1! entry)
- ;; Set the current source location for better diagnostics.
- ;; Access with current-reader-location.
- (reader-set-location! CURRENT-READER (location-property entry))
+ (let ((location (location-property entry)))
+
+ ;; Set the current source location for better diagnostics.
+ ;; Access with current-reader-location.
+ (reader-set-location! CURRENT-READER location)
- (if (reader-trace-commands? CURRENT-READER)
- (let ((loc (location-property entry)))
+ (if (reader-trace-commands? CURRENT-READER)
(message "Processing command:\n @ "
- (if loc (location->string loc) "location unknown")
+ (if location (location->string location) "location unknown")
"\n"
- (with-output-to-string (lambda () (pretty-print entry))))))
-
- (let ((command (-reader-lookup-command (car entry))))
- (if command
- (let* ((handler (command-handler command))
- (arg-spec (command-arg-spec command))
- (num-args (num-args arg-spec)))
- (if (cdr num-args)
- ; Variable number of trailing arguments.
- (if (< (length (cdr entry)) (car num-args))
- (reader-error (string-append "Incorrect number of arguments to "
- (symbol->string (car entry))
- ", expecting at least "
- (number->string (car num-args)))
- entry
- (command-help command))
- (apply handler (cdr entry)))
- ; Fixed number of arguments.
- (if (!= (length (cdr entry)) (car num-args))
- (reader-error (string-append "Incorrect number of arguments to "
- (symbol->string (car entry))
- ", expecting "
- (number->string (car num-args)))
- entry
- (command-help command))
- (apply handler (cdr entry)))))
- (reader-error "unknown entry type" entry "")))
+ (with-output-to-string (lambda () (pretty-print entry)))))
+
+ (let ((command (-reader-lookup-command (car entry)))
+ (context (make-current-context #f)))
+
+ (if command
+
+ (let* ((handler (command-handler command))
+ (arg-spec (command-arg-spec command))
+ (num-args (num-args arg-spec)))
+ (if (cdr num-args)
+ ;; Variable number of trailing arguments.
+ (if (< (length (cdr entry)) (car num-args))
+ (parse-error context
+ (string-append "Incorrect number of arguments to "
+ (symbol->string (car entry))
+ ", expecting at least "
+ (number->string (car num-args)))
+ entry
+ (command-help command))
+ (apply handler (cdr entry)))
+ ;; Fixed number of arguments.
+ (if (!= (length (cdr entry)) (car num-args))
+ (parse-error context
+ (string-append "Incorrect number of arguments to "
+ (symbol->string (car entry))
+ ", expecting "
+ (number->string (car num-args)))
+ entry
+ (command-help command))
+ (apply handler (cdr entry)))))
+
+ (parse-error context "unknown entry type" entry))))
*UNSPECIFIED*
)
(define (-reader-process! entry loc)
(if (not (form? entry))
- (reader-error "improperly formed entry" entry ""))
+ (parse-error loc "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
(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.
+ (parse-error #f
+ "wrong number of arguments to `if'"
+ (cons 'if (cons test (cons then else)))))
; ??? 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 ""))
+ (if (or (not (pair? test))
+ (not (memq (car test) '(keep-isa? keep-mach? application-is?))))
+ (parse-error #f
+ "only (if (keep-mach?|keep-isa?|application-is? ...) ...) are currently supported"
+ test))
(case (car test)
((keep-isa?)
(if (keep-isa? (cadr test))
(define (option-arg args)
(if (and (pair? args) (pair? (cdr args)))
(cadr args)
- (parse-error "option processing" "missing argument to" (car args)))
+ (parse-error (make-prefix-context "option processing")
+ "missing argument to"
+ (car args)))
)
; List of common arguments.
(string-upcase (gen-c-symbol val))) ; yes, upcase
((string? val) val)
(else
- (parse-error "case:" "bad case" val)))
+ (parse-error (make-prefix-context "case:")
+ "bad case" val)))
" : ")
)
; Cover-fn to context-error for signalling an error during rtx traversal.
(define (-rtx-traverse-error tstate errmsg expr op-num)
-; (parse-error context (string-append errmsg ", operand number "
-; (number->string op-num))
-; (rtx-dump expr))
+; (parse-error (tstate-context context)
+; (string-append errmsg ", operand number "
+; (number->string op-num))
+; (rtx-dump expr))
(context-error (tstate-context tstate)
(string-append errmsg ", operand #" (number->string op-num))
(rtx-strdump expr))
)
(define (-rtx-traverse-attrs val mode expr op-num tstate appstuff)
-; (cons val ; (atlist-source-form (atlist-parse val "" "with-attr"))
+; (cons val ; (atlist-source-form (atlist-parse (make-prefix-context "with-attr") val ""))
; tstate)
#f
)
(define (hw estate mode-name hw-name index-arg selector)
; Enforce some rules to keep things in line with the current design.
(if (not (symbol? mode-name))
- (parse-error "hw" "invalid mode name" mode-name))
+ (parse-error (estate-context estate) "invalid mode name" mode-name))
(if (not (symbol? hw-name))
- (parse-error "hw" "invalid hw name" hw-name))
+ (parse-error (estate-context estate) "invalid hw name" hw-name))
(if (not (or (number? index-arg)
(rtx? index-arg)))
- (parse-error "hw" "invalid index" index-arg))
+ (parse-error (estate-context estate) "invalid index" index-arg))
(if (not (or (number? selector)
(rtx? selector)))
- (parse-error "hw" "invalid selector" selector))
+ (parse-error (estate-context estate) "invalid selector" selector))
(let ((hw (current-hw-sem-lookup-1 hw-name)))
(if (not hw)
- (parse-error "hw" "invalid hardware element" hw-name))
+ (parse-error (estate-context estate) "invalid hardware element" hw-name))
(let* ((mode (if (eq? mode-name 'DFLT) (hw-mode hw) (mode:lookup mode-name)))
(hw-name-with-mode (symbol-append hw-name '- (obj:name mode)))
(result (new <operand>))) ; ??? lookup-for-new?
(if (not mode)
- (parse-error "hw" "invalid mode" mode-name))
+ (parse-error (estate-context estate) "invalid mode" mode-name))
; Record the selector.
(elm-xset! result 'selector selector)
(rtx-constant-value index-arg))
(make <hw-index> 'anonymous 'rtx DFLT
(-rtx-closure-make estate index-arg))))
- (else (parse-error "hw" "invalid index" index-arg))))
+ (else (parse-error (estate-context estate)
+ "invalid index" index-arg))))
(if (not (hw-mode-ok? hw (obj:name mode) (elm-xget result 'index)))
- (parse-error "hw" "invalid mode for hardware" mode-name))
+ (parse-error (estate-context estate)
+ "invalid mode for hardware" mode-name))
(elm-xset! result 'hw-name hw-name)
(elm-xset! result 'type hw)
; Subroutines.
; ??? Not sure this should live here.
-(define (-subr-read errtxt . arg-list)
+(define (-subr-read context . arg-list)
#f
)
(make <sfrag>
'x-header
"header fragment for insns without one"
- (atlist-parse '(VIRTUAL) "" "semantic frag computation")
+ (atlist-parse (make-prefix-context "semantic frag computation")
+ '(VIRTUAL) "")
nil ; users
nil ; user ordinals
(insn-sfmt (current-insn-lookup 'x-before))
(make <sfrag>
'x-trailer
"trailer fragment for insns without one"
- (atlist-parse '(VIRTUAL) "" "semantic frag computation")
+ (atlist-parse (make-prefix-context "semantic frag computation")
+ '(VIRTUAL) "")
nil ; users
nil ; user ordinals
(insn-sfmt (current-insn-lookup 'x-before))
(append! op-list (list try))
(cadr try))))
- (parse-error "FIXME" "unknown reg" expr)))
+ (parse-error (tstate-context tstate) "unknown reg" expr)))
)
; Subroutine of semantic-compile:process-expr!, to simplify it.
(indx-sel (rtx-mem-index-sel expr)))
(if (memq mode '(DFLT VOID))
- (parse-error "FIXME" "memory must have explicit mode" expr))
+ (parse-error (tstate-context tstate)
+ "memory must have explicit mode" expr))
(let* ((try (list 'mem #f mode 'h-memory indx-sel))
(existing-op (-rtx-find-op try op-list)))
(f (current-ifld-lookup f-name)))
(if (not f)
- (parse-error "FIXME" "unknown ifield" f-name))
+ (parse-error (tstate-context tstate) "unknown ifield" f-name))
(let* ((mode (obj:name (ifld-mode f)))
(try (list '-op- #f mode f-name #f))
(define (-build-index-of-operand! expr tstate op-list)
(if (not (and (rtx? (rtx-index-of-value expr))
(rtx-kind? 'operand (rtx-index-of-value expr))))
- (parse-error "FIXME" "only `(index-of operand)' is currently supported"
+ (parse-error (tstate-context tstate)
+ "only `(index-of operand)' is currently supported"
expr))
(let ((op (rtx-operand-obj (rtx-index-of-value expr))))
(let ((indx (op:index op)))
(if (not (eq? (hw-index:type indx) 'ifield))
- (parse-error "FIXME" "only ifield indices are currently supported"
+ (parse-error (tstate-context tstate)
+ "only ifield indices are currently supported"
expr))
(let* ((f (hw-index:value indx))
(f-name (obj:name f)))
(assert (rtx? sem-code))
(let*
- ; String for error messages.
- ((errtxt "semantic compilation")
-
+ (
; These record the result of traversing SEM-CODE.
; They're lists of (type object mode name [args ...]).
; TYPE is one of: -op- reg mem.
(cond ((number? regno) #t)
((form? regno)
(rtx-traverse-operands rtx-obj expr tstate appstuff))
- (else (parse-error errtxt
+ (else (parse-error (tstate-context tstate)
"invalid register number"
regno)))
(-build-reg-operand! expr tstate
; Instruction fields.
((ifield) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
(if (not (eq? ref-type 'use))
- (parse-error errtxt "can't set an `ifield'" expr))
+ (parse-error (tstate-context tstate)
+ "can't set an `ifield'" expr))
(-build-ifield-operand! expr tstate in-ops)))
; Hardware indices.
; For constants, this is the constant.
((index-of) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
(if (not (eq? ref-type 'use))
- (parse-error errtxt "can't set an `index-of'" expr))
+ (parse-error (tstate-context tstate)
+ "can't set an `index-of'" expr))
(-build-index-of-operand! expr tstate in-ops)))
; Machine generate the SKIP-CTI attribute.
"End of operands.\n"))
(csem-make compiled-expr sorted-ins sorted-outs
- (atlist-parse sem-attrs "" "semantic attributes")))))
+ (atlist-parse context sem-attrs "")))))
)
\f
; Traverse SEM-CODE, computing attributes derivable from it.
(assert (rtx? sem-code))
(let*
- ; String for error messages.
- ((errtxt "semantic attribute computation")
-
+ (
; List of attributes computed from SEM-CODE.
; The first element is just a dummy so that append! always works.
(sem-attrs (list #f))
(let
; Drop dummy first arg.
((sem-attrs (cdr sem-attrs)))
- (atlist-parse sem-attrs "" "semantic attributes")))
+ (atlist-parse context sem-attrs "")))
)
";\n")
""))
(else
- (parse-error "insn function unit spec"
+ (parse-error (make-prefix-context "insn function unit spec")
"invalid spec" arg))))
overrides)
; Create bitmask indicating which args were referenced.
(define (-create-virtual-insns! isa)
(let ((isa-name (obj:name isa))
- (context "virtual insns")
+ (context (make-prefix-context "virtual insns"))
;; Record as a pair so -virtual-insn-add! can update it.
(ordinal (cons #f -1)))
";\n")
""))
(else
- (parse-error "insn function unit spec"
+ (parse-error (make-prefix-context "insn function unit spec")
"invalid spec" arg))))
overrides)
; Create bitmask indicating which args were referenced.
(define (-create-virtual-insns!)
(let ((all (all-isas-attr-value))
- (context "virtual insns")
+ (context (make-prefix-context "virtual insns"))
;; Record as a pair so -virtual-insn-add! can update it.
(ordinal (cons #f -1)))
; TYPE-SPEC is: (mode [(dimensions ...)])
; or: ((mode bits) [(dimensions ...)])
-(define (parse-type errtxt type-spec)
+(define (parse-type context type-spec)
; Preliminary error checking.
(let ((expected
", expected (mode [(dimensions)]) or ((mode bits) [(dimensions)])"))
(if (not (list? type-spec))
- (parse-error errtxt (string-append "invalid type spec" expected)
+ (parse-error context (string-append "invalid type spec" expected)
type-spec))
(let ((len (length type-spec)))
(if (or (< len 1)
(> len 2))
- (parse-error errtxt (string-append "invalid type spec" expected)
+ (parse-error context (string-append "invalid type spec" expected)
type-spec))
; Validate the mode spec.
(cond ((symbol? (car type-spec))
((list? (car type-spec))
(begin
(if (not (= (length (car type-spec)) 2))
- (parse-error errtxt
+ (parse-error context
(string-append "invalid mode in type spec"
expected)
type-spec))
(if (not (symbol? (caar type-spec)))
- (parse-error errtxt
+ (parse-error context
(string-append "invalid mode in type spec"
expected)
type-spec))
(if (not (integer? (cadar type-spec)))
- (parse-error errtxt
+ (parse-error context
(string-append "invalid #bits in type spec"
expected)
type-spec))
))
(else
- (parse-error errtxt
+ (parse-error context
(string-append "invalid mode in type spec" expected)
type-spec)))
; Validate the dimension list if present.
(if (or (not (list? (cadr type-spec)))
(not (all-true? (map non-negative-integer?
(cadr type-spec)))))
- (parse-error errtxt
+ (parse-error context
(string-append "invalid dimension spec in type spec"
expected)
type-spec)))
(dims (if (> (length type-spec) 1) (cadr type-spec) nil)))
; Look up the mode and create the mode object.
- (let* ((base-mode (parse-mode-name mode errtxt))
+ (let* ((base-mode (parse-mode-name context mode))
(mode-obj
(cond ((eq? mode 'INT)
(mode-make-int bits))
(mode-make-uint bits))
(else
(if (and bits (!= bits (mode:bits base-mode)))
- (parse-error errtxt "wrong number of bits for mode"
+ (parse-error context "wrong number of bits for mode"
bits))
base-mode))))
;;; Return a single-location in a readable form.
(define (single-location->string sloc)
+ ;; +1: numbers are recorded origin-0
(string-append (single-location-file sloc)
":"
- ;; +1: numbers are recorded origin-0
- (number->string (+ (single-location-line sloc)
- 1))
+ (number->string (+ (single-location-line sloc) 1))
":"
- (number->string (+ (single-location-column sloc)
- 1))
- (if (single-location-end? sloc) "(end)" "")
- )
+ (number->string (+ (single-location-column sloc) 1))
+ (if (single-location-end? sloc) "(end)" ""))
+)
+
+;;; Same as single-location->string, except omit any directory info in
+;;; the file name.
+
+(define (single-location->simple-string sloc)
+ ;; +1: numbers are recorded origin-0
+ (string-append (basename (single-location-file sloc))
+ ":"
+ (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.
\f
; Parsing utilities
-; Parsing context, used to give better error messages.
+;;; A parsing/processing context, used to give better error messages.
+;;; LOCATION must be an object created with make-location.
(define <context>
(class-make '<context> nil
'(
- ; Name of file containing object being processed.
- (file . #f)
- ; Line number in the file.
- (lineno . #f)
- ; Error message prefix
- (prefix . "")
+ ;; Location of the object being processed,
+ ;; or #f if unknown (or there is none).
+ (location . #f)
+ ;; Error message prefix or #f if there is none.
+ (prefix . #f)
)
nil)
)
; Accessors.
-(define-getters <context> context (file lineno prefix))
+(define-getters <context> context (location prefix))
; Create a <context> object that is just a prefix.
-(define (context-make-prefix prefix)
- (make <context> #f #f prefix)
+(define (make-prefix-context prefix)
+ (make <context> #f prefix)
+)
+
+; Create a <context> object that (current-reader-location) with PREFIX.
+
+(define (make-current-context prefix)
+ (make <context> (current-reader-location) prefix)
+)
+
+; Create a new context from CONTEXT with TEXT appended to the prefix.
+
+(define (context-append context text)
+ (make <context> (context-location context)
+ (string-append (context-prefix context) text))
)
-; Create a <context> object for the reader.
-; This sets file,lineno from (current-input-port).
+; Create a new context from CONTEXT with NAME appended to the prefix.
-(define (context-make-reader prefix)
- (make <context>
- (or (port-filename (current-input-port))
- "<input>")
- (port-line (current-input-port))
- prefix)
+(define (context-append-name context name)
+ (context-append context (stringsym-append ":" name))
)
; Call this to issue an error message.
; ARG is the value that had the error if there is one.
(define (context-error context errmsg . arg)
- (cond ((and context (context-file context))
+ (cond ((and context (context-location context))
(let ((msg (string-append
- (context-file context) ":"
- (number->string (context-lineno context)) ": "
+ "@ "
+ (location->string (context-location context))
+ ": "
(context-prefix context) ": "
errmsg ": ")))
(apply error (cons msg arg))))
; together. Each element can in turn be a list of symbols, and so on.
; This supports symbol concatenation in the description file without having
; to using string-append or some such.
-; FIXME: Isn't the plan to move ERRTXT to the 1st arg?
-(define (parse-name name errtxt)
+(define (parse-name context name)
(string->symbol
(let parse ((name name))
(cond
((list? name) (string-map parse name))
((symbol? name) (symbol->string name))
((string? name) name)
- (else (parse-error errtxt "improper name" name)))))
+ (else (parse-error context "improper name" name)))))
)
; Parse an object comment.
; COMMENT is either a string or a list of strings, each element of which may
; in turn be a list of strings.
-; FIXME: Isn't the plan to move ERRTXT to the 1st arg?
-(define (parse-comment comment errtxt)
+(define (parse-comment context comment)
(cond ((list? comment)
- (string-map (lambda (elm) (parse-comment elm errtxt)) comment))
+ (string-map (lambda (elm) (parse-comment context elm)) comment))
((or (string? comment) (symbol? comment))
(->string comment))
- (else (parse-error errtxt "improper comment" comment)))
+ (else (parse-error context "improper comment" comment)))
)
; Parse a symbol.
; Parse a number.
; VALID-VALUES is a list of numbers and (min . max) pairs.
-(define (parse-number errtxt value . valid-values)
+(define (parse-number context value . valid-values)
(if (not (number? value))
- (parse-error errtxt "not a number" value))
+ (parse-error context "not a number" value))
(if (any-true? (map (lambda (test)
(if (pair? test)
(and (>= value (car test))
(= value test)))
valid-values))
value
- (parse-error errtxt "invalid number" value valid-values))
+ (parse-error context "invalid number" value valid-values))
)
; Parse a boolean value
; This is done by each of the argument validation routines so the caller
; doesn't need to make two calls.
-(define (arg-list-validate-name errtxt arg-spec)
+(define (arg-list-validate-name context arg-spec)
(if (null? arg-spec)
- (parse-error errtxt "empty argument spec"))
+ (parse-error context "empty argument spec" arg-spec))
(if (not (symbol? (car arg-spec)))
- (parse-error errtxt "argument name not a symbol" arg-spec))
+ (parse-error context "argument name not a symbol" arg-spec))
*UNSPECIFIED*
)
; Signal a parse error if an argument was specified with a value.
; ARG-SPEC is (name value).
-(define (arg-list-check-no-args errtxt arg-spec)
- (arg-list-validate-name errtxt arg-spec)
+(define (arg-list-check-no-args context arg-spec)
+ (arg-list-validate-name context arg-spec)
(if (not (null? (cdr arg-spec)))
- (parse-error errtxt (string-append (car arg-spec)
- " takes zero arguments")))
+ (parse-error context (string-append (car arg-spec)
+ " takes zero arguments")))
*UNSPECIFIED*
)
; Validate and return a symbol argument.
; ARG-SPEC is (name value).
-(define (arg-list-symbol-arg errtxt arg-spec)
- (arg-list-validate-name errtxt arg-spec)
+(define (arg-list-symbol-arg context arg-spec)
+ (arg-list-validate-name context arg-spec)
(if (or (!= (length (cdr arg-spec)) 1)
(not (symbol? (cadr arg-spec))))
- (parse-error errtxt (string-append (car arg-spec)
- ": argument not a symbol")))
+ (parse-error context (string-append (car arg-spec)
+ ": argument not a symbol")))
(cadr arg-spec)
)
\f
((operand) (set! entry (current-op-lookup entry-name)))
((insn) (set! entry (current-insn-lookup entry-name)))
((macro-insn) (set! entry (current-minsn-lookup entry-name)))
- (else (parse-error "sanitize" "unknown entry type" entry-type)))
+ (else (parse-error (make-prefix-context "sanitize")
+ "unknown entry type" entry-type)))
; ENTRY is #f in the case where the element was discarded
; because its mach wasn't selected. But in the case where
))
(if (and (eq? APPLICATION 'OPCODES) (keep-all?))
- (parse-error "sanitize"
+ (parse-error (make-prefix-context "sanitize")
(string-append "unknown " entry-type)
entry-name)))))
entry-names)
OSDN Git Service
