2003-07-15 Doug Evans <dje@sebabeach.org>
+ Add guile 1.6.4 support.
+ - empty list must be quoted
+ - string functions have stricter type checking
+ - eval now takes a second argument
+ - symbol-bound? is deprecated
+ * attr.scm (-attr-parse): Use stringsym-append to build errtxt.
+ (bitset-attr->list): Ensure arg to string-cut is a string.
+ (attr-parse): Ensure args to string-ref and string-drop1 are strings.
+ (<enum-attribute>,gen-value-for-defn): Fetch string name of self.
+ * cos.scm (-class-list): Must quote empty list.
+ (-class-parent-classes,-class-compute-class-desc): Ditto.
+ (class-make,make,object-reset!): Ditto.
+ (method-make-make!): Call eval1 instead of eval.
+ (method-make-forward!,method-make-virtual-forward!): Ditto.
+ * decode.scm (subdtable-add): Use stringsym-append instead of
+ string-append.
+ (-gen-exprtable-name): Fetch string name of exprtable-entry-insn.
+ (-build-decode-table-entry): Fetch string name of insn.
+ * desc-cpu.scm (-gen-isa-table-defns): Fetch string name of isa.
+ (-gen-mach-table-defns): Ditto for mach.
+ (gen-ifld-defns): Ditto for ifld.
+ (gen-hw-table-defns): Ditto for hw.
+ (gen-operand-table): Ditto for op.
+ (gen-insn-table-entry): Ditto for insn.
+ * desc.scm (gen-attr-table-defn): Ditto for attr.
+ (<keyword>,gen-defn): Don't pass symbols to string-append.
+ * enum.scm (parse-enum-vals): Use symbolstr-append instead of
+ symbol-append.
+ (enum-vals-upcase): Use symbol-upcase to build result.
+ (-enum-parse): Use stringsym-append to build errtxt.
+ * fixup.scm (*guile-major-version*,*guile-minor-version*): New globals.
+ (eval1): New function.
+ (symbol-bound?): Provide own version if >= guile 1.6.
+ * hardware.scm (define-keyword): Use string-append instead of
+ symbol-append.
+ * html.scm (gen-html-header,gen-table-of-contents,gen-arch-intro,
+ cgen.html,cgen-insn.html): Convert current-arch-name to a string
+ before using.
+ (gen-list-entry): Handle either symbol or string `name' arg.
+ (gen-obj-doc-header): Fetch string name of `o' arg.
+ (define-cpu-intro): Ditto for cpu.
+ (gen-mach-intro): Ditto for mach.
+ (gen-model-intro): Ditto for model.
+ (gen-isa-intro): Ditto for isa.
+ (gen-machine-doc-1): Ditto for isa.
+ (gen-reg-doc-1): Convert mach to string first.
+ (gen-insn-doc-1): Ditto. Convert model/unit names to strings first.
+ (gen-insn-doc-list): Fetch string name of mach. Convert insn name
+ to string first.
+ (gen-insn-categories): Fetch string name of mach. Convert
+ enum-val-name to string first.
+ (gen-insn-docs): Fetch string name of mach.
+ * ifield.scm (ifld-ilk): Result is a string.
+ * iformat.scm (-ifmt-search-key): Convert attr value to string first.
+ Fetch string name of ifld.
+ (-sfmt-search-key): Similarily for ifld and op.
+ * insn.scm (syntax-make): Fetch string name of syntax element.
+ * mach.scm (-cpu-parse): Use stringsym-append to build errtxt.
+ * minsn.scm (minsn-make-alias): Fetch string name of minsn.
+ * mode.scm (mode:c-type): Result is a string.
+ (mode:enum): Fetch string name of mode.
+ (-mode-parse): Use stringsym-append to build errtxt.
+ * model.scm (model:enum): Fetch string name of model.
+ (-model-parse): Use stringsym-append to build errtxt.
+ (parse-insn-timing): Must quote empty list.
+ * opc-itab.scm (-gen-minsn-table-entry): Fetch string name of minsn.
+ (-gen-minsn-opcode-entry): Ditto.
+ * opcodes.scm (<operand>,gen-function-name): `what' arg is a symbol,
+ convert to string.
+ (read-cpu.opc): Convert current-arch-name to a string before using.
+ * operand.scm (<operand>,gen-pretty-name): Ensure `name' is a string.
+ (<derived-operand>): Must quote empty list.
+ (op-sort): Simplify, call alpha-sort-obj-list to do sort.
+ * pgmr-tools.scm (pgmr-pretty-print-insn-value): Fetch string name
+ of ifld.
+ * pmacros.scm (-pmacro-build-lambda): Use eval1 instead of eval.
+ (-pmacro-sym): Must convert symbols to strings before passing to
+ string-append.
+ (-pmacro-str): Ditto.
+ (pmacros-init!): Use eval1 instead of eval.
+ * read.scm (keep-mach-atlist?): Simplify, use bitset-attr->list.
+ (keep-isa-atlist?): Ditto.
+ (cmd-if): Use eval1 instead of eval.
+ * rtl-c.scm (<c-expr>,get-name): Fetch string name of self.
+ (-rtl-c-get): Fetch string name of src.
+ (s-unop): Ditto for mode.
+ (s-binop,s-binop-with-bit,s-shop,s-convop,s-cmpop): Ditto.
+ (-gen-par-temp-defns,subword): Ditto.
+ (join): Use stringsym-append instead of string-append.
+ * rtl-traverse.scm (rtx-option?): Convert option to string first.
+ (rtx-traverse-debug): Fetch string name of rtx-obj.
+ * rtl.scm (def-rtx-node): Use eval1 instead of eval.
+ (def-rtx-syntax-node,def-rtx-operand-node,def-rtx-macro-node): Ditto.
+ (rtx-pretty-name): Result is a string.
+ (-rtx-hw-name): Use symbolstr-append instead of symbol-append.
+ * semantics.scm (semantic-compile): Simplify, use alpha-sort-obj-list.
+ * sid-cpu.scm (cgen-write.cxx): Convert current-arch-name to a string
+ before using.
+ (-gen-sfrag-case): Fetch string name of user.
+ * sid-model.scm (unit:enum): Fetch string name of unit.
+ * sid.scm (<hw-memory>,cxmake-get): Fetch string name of mode.
+ (<hw-memory>,gen-set-quiet): Ditto.
+ (gen-mode-defs): Ditto.
+ (sim-finish!): Convert current-arch-name to a string before using.
+ * sim-cpu.scm (-gen-scache-semantic-fn): Fetch string name of insn.
+ (-gen-no-scache-semantic-fn): Ditto.
+ (cgen-defs.h): Fetch string name of isa.
+ (cgen-read.c): Convert current-arch-name to a string before using.
+ (cgen-write.c): Ditto.
+ * sim-model.scm (unit:enum): Fetch string name of unit.
+ (gen-model-fn-decls): Use stringsym-append instead of string-append.
+ (-gen-model-timing-table): Fetch string name of model.
+ (-gen-mach-model-table): Ditto.
+ (-gen-mach-defns): Fetch string name of mach.
+ * sim.scm (gen-reg-access-defn): Fetch string name of hw.
+ (<hw-memory>,cxmake-get): Fetch string name of mode.
+ (<hw-memory>,gen-set-quiet): Ditto.
+ (gen-mode-defs): Ditto.
+ (sim-finish!): Must quote empty list.
+ * utils-cgen.scm (<ident>): Must quote empty list.
+ (obj:str-name): New fn.
+ (parse-comment): Result is a string.
+ (parse-symbol): Result is a symbol.
+ (parse-string): Result is a string.
+ (keyword-list?): Convert arg to string before calling string-ref.
+ (keyword-list->arg-list): Ditto.
+ (gen-attr-name): Convert attr-name to string first.
+ (alpha-sort-obj-list): Use symbol<? instead of string<?.
+ * utils-gen.scm (attr-gen-decl): Fetch string name of attr.
+ (gen-define-ifmt-ifields): Ditto for fld.
+ * utils.scm (gen-c-symbol): Ensure str is a string before calling
+ map-over-string.
+ (gen-file-name): Ditto.
+ (symbol-downcase,symbol-upcase,symbol<?): New fns.
+ (stringsym-append,symbolstr-append,->string,->symbol): New fns.
+ (reduce): Call eval1 instead of eval.
+ * cpu/m32r.cpu (addi): Don't use `#.'.
+
* gen-all-sim: Fix some typos.
2003-07-08 Doug Evans <dje@sebabeach.org>
(define (-attr-parse errtxt type-class name comment attrs for default values)
(logit 2 "Processing attribute " name " ...\n")
(let* ((name (parse-name name errtxt))
- (errtxt (string-append errtxt ":" name))
+ (errtxt (stringsym-append errtxt ":" name))
(result (new type-class))
(parsed-values (send result 'parse-value-def errtxt values)))
(elm-xset! result 'name name)
; Convert a bitset value "a,b,c" into a list (a b c).
(define (bitset-attr->list x)
- (map string->symbol (string-cut x #\,))
+ (map string->symbol (string-cut (->string x) #\,))
)
; Return the enum of ATTR-NAME for type TYPE.
(for-each (lambda (elm)
(cond ((symbol? elm)
; boolean attribute
- (if (char=? (string-ref elm 0) #\!)
- (set! alist (acons (string->symbol (string-drop1 elm)) #f alist))
+ (if (char=? (string-ref (symbol->string elm) 0) #\!)
+ (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))))
(if (not value)
"0"
"1"))
- ;(string-upcase (string-append (obj:name self) "_" value)))
+ ;(string-upcase (string-append (obj:str-name self) "_" value)))
)
(method-make!
(method-make!
<enum-attribute> 'gen-value-for-defn
(lambda (self value)
- (string-upcase (gen-c-symbol (string-append (obj:name self) "_" value))))
+ (string-upcase
+ (gen-c-symbol (string-append (obj:str-name self)
+ "_"
+ (symbol->string value)))))
)
\f
; Called before loading a .cpu file to initialize.
; List of all classes.
-(define -class-list ())
+(define -class-list '())
; ??? Were written as a procedures for Hobbit's sake (I think).
(define -object-unspecified #:unspecified)
(define (-class-parent-classes class)
; -class-parents returns the names, we want the actual classes.
(let loop ((parents (-class-parents class))
- (result ()))
+ (result '()))
(if (null? parents)
(reverse! result)
(let ((parent (class-lookup (car parents))))
(append! result
(let loop ((parents (-class-parents class))
- (parent-descs ())
+ (parent-descs '())
(base-offset base-offset))
(if (null? parents)
(reverse! parent-descs)
; offset).
; Elements are recorded as (symbol initial-value private? . vector-index)
; FIXME: For now all elements are marked as "public".
- (let loop ((elm-list-tmp ()) (index 0) (elms elms))
+ (let loop ((elm-list-tmp '()) (index 0) (elms elms))
(if (null? elms)
(set! elm-list (reverse! elm-list-tmp)) ; done
(if (pair? (car elms))
(list 'quote elm) elm))
args)
'(self))))
- (method-make! class 'make! (eval lambda-expr))
+ (method-make! class 'make! (eval1 lambda-expr))
)
)
; This puts all that in a cover function.
(define (make class . operands)
- (apply send (append (cons (new class) ()) '(make!) operands))
+ (apply send (append (cons (new class) '()) '(make!) operands))
)
; Return #t if class X is a subclass of BASE-NAME.
(for-each (lambda (method-name)
(method-make!
class method-name
- (eval `(lambda args
- (apply send
- (cons (elm-get (car args)
- (quote ,elm-name))
- (cons (quote ,method-name)
- (cdr args))))))))
+ (eval1 `(lambda args
+ (apply send
+ (cons (elm-get (car args)
+ (quote ,elm-name))
+ (cons (quote ,method-name)
+ (cdr args))))))))
methods)
-object-unspecified
)
(for-each (lambda (method-name)
(method-make-virtual!
class method-name
- (eval `(lambda args
- (apply send
- (cons (elm-get (car args)
- (quote ,elm-name))
- (cons (quote ,method-name)
- (cdr args))))))))
+ (eval1 `(lambda args
+ (apply send
+ (cons (elm-get (car args)
+ (quote ,elm-name))
+ (cons (quote ,method-name)
+ (cdr args))))))))
methods)
-object-unspecified
)
; Reset the object system (delete all classes).
(define (object-reset!)
- (set! -class-list ())
+ (set! -class-list '())
-object-unspecified
)
(dni addi "addi"
((PIPE OS) (IDOC ALU))
- ; #.: experiment
- #.(string-append "addi " "$dr,$simm8")
+ ;#.(string-append "addi " "$dr,$simm8") ; #. experiment
+ "addi $dr,$simm8"
(+ OP1_4 dr simm8)
(set dr (add dr simm8))
((m32r/d (unit u-exec))
(lambda (elm)
(case (dtable-entry-type elm)
((insn)
- (string-append " " (obj:name (dtable-entry-value elm))))
+ (stringsym-append " " (obj:name (dtable-entry-value elm))))
((table)
- (string-append " " (subdtable-name (dtable-entry-value elm))))
+ (stringsym-append " " (subdtable-name (dtable-entry-value elm))))
((expr)
- (string-append " " (exprtable-name (dtable-entry-value elm))))
+ (stringsym-append " " (exprtable-name (dtable-entry-value elm))))
(else (error "bad dtable entry type:"
(dtable-entry-type elm)))))
(dtable-guts-entries subtable-guts)))))
(define (-gen-exprtable-name insn-exprs)
(string-map (lambda (x)
- (string-append (obj:name (exprtable-entry-insn x))
+ (string-append (obj:str-name (exprtable-entry-insn x))
"-"
(rtx-strdump (exprtable-entry-expr x))))
insn-exprs)
; Each "slot" is a list of matching instructions.
(define (-fill-slot! insn-vec insn bitnums lsb0?)
- ;(display (string-append "fill-slot!: " (obj:name insn) " ")) (display bitnums) (newline)
+ ;(display (string-append "fill-slot!: " (obj:str-name insn) " ")) (display bitnums) (newline)
(let ((slot-nums (-opcode-slots insn bitnums lsb0?)))
;(display (list "Filling slot(s)" slot-nums "...")) (newline)
(for-each (lambda (slot-num)
(message "WARNING: Decoder ambiguity detected: "
(string-drop1 ; drop leading comma
(string-map (lambda (insn)
- (string-append ", " (obj:name insn)))
+ (string-append ", " (obj:str-name insn)))
slot))
"\n"))
; Things aren't entirely hopeless. We've warned about the ambiguity.
(gen-obj-sanitize
isa
(string-append " { "
- "\"" (obj:name isa) "\", "
+ "\"" (obj:str-name isa) "\", "
(number->string
(isa-default-insn-bitsize isa))
", "
(gen-obj-sanitize
mach
(string-append " { "
- "\"" (obj:name mach) "\", "
+ "\"" (obj:str-name mach) "\", "
"\"" (mach-bfd-name mach) "\", "
(mach-enum mach) ", "
(number->string (cpu-insn-chunk-bitsize (mach-cpu mach)))
(string-append
" { "
(ifld-enum ifld) ", "
- "\"" (obj:name ifld) "\", "
+ "\"" (obj:str-name ifld) "\", "
(if
(or (has-attr? ifld 'VIRTUAL)
(derived-ifield? ifld))
(gen-obj-sanitize hw
(string-list
" { "
- "\"" (obj:name hw) "\", "
+ "\"" (obj:str-name hw) "\", "
(hw-enum hw) ", "
; ??? No element currently requires both indices and
; values specs so we only output the needed one.
(lambda (op)
(gen-obj-sanitize op
(string-append
- "/* " (obj:name op) ": " (obj:comment op) " */\n"
+ "/* " (obj:str-name op) ": " (obj:comment op) " */\n"
(if (or (derived-operand? op)
(anyof-operand? op))
""
(string-append
" { "
- "\"" (obj:name op) "\", "
+ "\"" (obj:str-name op) "\", "
(op-enum op) ", "
(hw-enum (op:hw-name op)) ", "
(number->string (op:start op)) ", "
" {\n"
" "
(if (has-attr? insn 'ALIAS) "-1" (insn-enum insn)) ", "
- "\"" (obj:name insn) "\", "
+ "\"" (obj:str-name insn) "\", "
"\"" (insn-mnemonic insn) "\", "
;(if (has-attr? insn 'ALIAS) "0" (number->string (insn-length insn))) ",\n"
(number->string (insn-length insn)) ",\n"
attr
(string-append " { "
"\""
- (string-upcase (obj:name attr))
+ (string-upcase (obj:str-name attr))
"\", "
(if (class-instance? <boolean-attribute> attr)
"&bool_attr[0], &bool_attr[0]"
(string-map (lambda (e)
(string-append
" { \""
- (elm-get self 'prefix) (car e) ; operand name
+ (->string (elm-get self 'prefix))
+ (->string (car e)) ; operand name
"\", "
(if (string? (cadr e))
(cadr e)
(+ last 1))))
(if (eq? (car remaining) '-)
(loop result val (cdr remaining))
- (let ((name (symbol-append prefix
- (if (pair? (car remaining))
- (caar remaining)
- (car remaining))))
+ (let ((name (symbolstr-append prefix
+ (if (pair? (car remaining))
+ (caar remaining)
+ (car remaining))))
(attrs (if (and (pair? (car remaining))
(pair? (cdar remaining))
(pair? (cddar remaining)))
(define (enum-vals-upcase vals)
(map (lambda (elm)
- (cons (string->symbol (string-upcase (car elm))) (cdr elm)))
+ (cons (symbol-upcase (car elm)) (cdr elm)))
vals)
)
\f
(logit 2 "Processing enum " name " ...\n")
(let* ((name (parse-name name errtxt))
- (errtxt (string-append errtxt " " name)))
+ (errtxt (stringsym-append errtxt " " name)))
(make <enum>
name
; This file is part of CGEN.
; See file COPYING.CGEN for details.
-; check for newer guile
+(define *guile-major-version* (string->number (major-version)))
+(define *guile-minor-version* (string->number (minor-version)))
+
+; eval takes a module argument in 1.6 and later
+
+(if (or (> *guile-major-version* 1)
+ (>= *guile-minor-version* 6))
+ (define (eval1 expr)
+ (eval expr (current-module)))
+ (define (eval1 expr)
+ (eval expr))
+)
+
+; symbol-bound? is deprecated in 1.6
+
+(if (or (> *guile-major-version* 1)
+ (>= *guile-minor-version* 6))
+ (define (symbol-bound? table s)
+ (if table
+ (error "must pass #f for symbol-bound? first arg"))
+ ; FIXME: Not sure this is 100% correct.
+ (module-defined? (current-module) s))
+)
(if (symbol-bound? #f 'load-from-path)
(begin
(define <keyword>
(class-make '<keyword> '(<hw-asm>)
'(
- ; Name to use in generated code.
+ ; Name to use in generated code, as a string.
print-name
; Prefix of each name in VALUES, as a string.
; to make periphery C/C++ code more legible.
(define-full-enum (obj:name kw) (obj:comment kw)
(atlist-source-form (obj-atlist kw))
- (string-upcase (symbol-append (kw-print-name kw) '-))
+ (string-upcase (string-append (kw-print-name kw) "-"))
(kw-values kw))))
kw))
)
; TODO: Add author arg so all replies for this arch go to right person.
(define (gen-html-header kind)
- (let ((arch (current-arch-name))
- (ARCH (string-upcase (current-arch-name))))
+ (let* ((arch (symbol->string (current-arch-name)))
+ (ARCH (string-upcase arch)))
(string-list
"<!doctype html public \"-//w3c//dtd html 4.0 transitional//en\">\n"
"<html>\n"
; INSN-FILE is the name of the .html file containing instruction definitions.
(define (gen-table-of-contents insn-file)
- (let ((ARCH (string-upcase (current-arch-name))))
+ (let ((ARCH (string-upcase (symbol->string (current-arch-name)))))
(string-list
"<h1>\n"
(string-append ARCH " Architecture Documentation")
(define (gen-list-entry name comment kind)
(string-append "<li>"
- "<a href=\"#" kind "-" name "\">"
- name
+ "<a href=\"#" kind "-" (->string name) "\">"
+ (->string name)
" - "
comment
"</a>\n"
; KIND is one of "mach", "model", etc.
(define (gen-obj-doc-header o kind)
- (gen-doc-header (string-append (obj:name o) " - " (obj:comment o))
- (string-append kind "-" (obj:name o)))
+ (gen-doc-header (string-append (obj:str-name o) " - " (obj:comment o))
+ (string-append kind "-" (obj:str-name o)))
)
\f
; Architecture page.
(define (gen-cpu-intro cpu)
(string-list
"<li>\n"
- (obj:name cpu) " - " (obj:comment cpu) "\n"
+ (obj:str-name cpu) " - " (obj:comment cpu) "\n"
"<br>\n"
"<br>\n"
"Machines:\n"
(define (gen-mach-intro mach)
(string-list
"<li>\n"
- (obj:name mach) " - " (obj:comment mach) "\n"
+ (obj:str-name mach) " - " (obj:comment mach) "\n"
"<br>\n"
"<br>\n"
"Models:\n"
(define (gen-model-intro model)
(string-list
"<li>\n"
- (obj:name model) " - " (obj:comment model) "\n"
+ (obj:str-name model) " - " (obj:comment model) "\n"
"<br>\n"
"</li>\n"
)
(define (gen-isa-intro isa)
(string-list
"<li>\n"
- (obj:name isa) " - " (obj:comment isa) "\n"
+ (obj:str-name isa) " - " (obj:comment isa) "\n"
"<br>\n"
; FIXME: wip
; I'd like to include the .cpu file tag here, but using English text
"")
(if (isa-condition isa)
(string-append "<li>condition-field: "
- (car (isa-condition isa))
+ (symbol->string (car (isa-condition isa)))
"</li>\n"
"<br>\n"
"<li>condition:\n"
(define (gen-arch-intro)
; NOTE: This includes cpu families.
- (let ((ARCH (string-upcase (current-arch-name)))
+ (let ((ARCH (string-upcase (symbol->string (current-arch-name))))
(isas (current-isa-list))
(cpus (current-cpu-list))
)
"<li>\n"
"isas: "
(string-map (lambda (isa)
- (string-append " " (obj:name isa)))
+ (string-append " " (obj:str-name isa)))
(mach-isas mach))
"\n"
"</li>\n"
"<li>\n"
"machines: "
(string-map (lambda (mach)
- (string-append " " mach))
+ (string-append " " (symbol->string mach)))
(bitset-attr->list (obj-attr-value reg 'MACH)))
"\n"
"</li>\n"
"<li>\n"
"machines: "
(string-map (lambda (mach)
- (string-append " " mach))
+ (string-append " " (symbol->string mach)))
(bitset-attr->list (obj-attr-value insn 'MACH)))
"\n"
"</li>\n"
(string-list-map
(lambda (t)
(string-append "<li>\n"
- (car t)
+ (->string (car t))
": "
(string-map (lambda (u)
(string-append " "
- (obj:name (iunit:unit u))))
+ (obj:str-name (iunit:unit u))))
(timing:units (cdr t)))
"\n"
"</li>\n"))
(define (gen-insn-doc-list mach name comment insns)
(string-list
"<hr>\n"
- (gen-doc-header (string-append (obj:name mach)
+ (gen-doc-header (string-append (obj:str-name mach)
" "
- name
+ (->string name)
(if (string=? comment "")
""
(string-append " - " comment)))
(string-append "mach-insns-"
- (obj:name mach)
+ (obj:str-name mach)
"-"
- name))
+ (->string name)))
"<ul>\n"
(string-list-map (lambda (o)
(gen-obj-list-entry o "insn"))
""
(string-list
"<li><a href=\"#mach-insns-"
- (obj:name mach)
+ (obj:str-name mach)
"-"
- (enum-val-name c)
+ (->string (enum-val-name c))
"\">"
- (enum-val-name c)
+ (->string (enum-val-name c))
(if (string=? comment "")
""
(string-append " - " comment))
))))
categories)
"<li><a href=\"#mach-insns-"
- (obj:name mach)
+ (obj:str-name mach)
"-"
- (obj:name mach)
+ (obj:str-name mach)
"\">alphabetically</a></li>\n"
"</ul>\n"
)
(mach-supports? m insn))
insns)))
(string-list "<li>"
- (obj:name m)
+ (obj:str-name m)
" - "
(obj:comment m)
"</li>\n"
(logit 1 "Generating " (current-arch-name) ".html ...\n")
(string-write
(gen-html-copyright (string-append "Architecture documentation for "
- (current-arch-name)
+ (symbol->string (current-arch-name))
".")
CURRENT-COPYRIGHT CURRENT-PACKAGE)
(gen-html-header "Architecture")
(logit 1 "Generating " (current-arch-name) "-insn.html ...\n")
(string-write
(gen-html-copyright (string-append "Instruction documentation for "
- (current-arch-name)
+ (symbol->string (current-arch-name))
".")
CURRENT-COPYRIGHT CURRENT-PACKAGE)
(gen-html-header "Instruction")
(define (ifield? x) (class-instance? <ifield> x))
-; Return ilk of field.
+; Return ilk of field as a string.
; ("ilk" sounds klunky but "type" is too ambiguous. Here "ilk" means
; the kind of the hardware element, enum, etc.)
; The result is a character string naming the field type.
; ??? One could require that the `value' field always be an object.
; I can't get too worked up over it yet.
(if (object? value)
- (obj:name value) ; send's message 'get-name to fetch object's `name'
+ (symbol->string (obj:name value)) ; send 'get-name to fetch the name
"#")) ; # -> "it's a number"
)
(define (-ifmt-search-key insn sorted-ifld-list)
(string-map (lambda (ifld)
(string-append " ("
- (or (obj-attr-value insn 'sanitize)
+ (or (->string (obj-attr-value insn 'sanitize))
"-nosan-")
" "
- (obj:name ifld)
+ (obj:str-name ifld)
" "
(ifld-ilk ifld)
")"))
(define (-sfmt-search-key insn cti? sorted-used-iflds sem-in-ops sem-out-ops)
(let ((op-key (lambda (op)
(string-append " ("
- (or (obj-attr-value insn 'sanitize)
+ (or (->string (obj-attr-value insn 'sanitize))
"-nosan-")
" "
- (obj:name op)
+ (obj:str-name op)
; ??? Including memory operands currently
; isn't necessary and it can account for some
; spurious differences. On the other hand
(if (memory? (op:type op))
""
(string-append " "
- (obj:name (op:mode op))))
+ (obj:str-name (op:mode op))))
; CGEN_OPERAND_INSTANCE_COND_REF is stored
; with the operand in the operand instance
; table thus formats must be distinguished
cti?
(insn-length insn)
(string-map (lambda (ifld)
- (string-append " (" (obj:name ifld) " " (ifld-ilk ifld) ")"))
+ (string-append " (" (obj:str-name ifld) " " (ifld-ilk ifld) ")"))
sorted-used-iflds)
(string-map op-key
sem-in-ops)
e)
(else
(assert (operand? e))
- (string-append "${" (obj:name e) "}"))))
+ (string-append "${" (obj:str-name e) "}"))))
elements))
)
\f
(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 (string-append "cpu " name)))
+ (errtxt (stringsym-append "cpu " name)))
(if (keep-cpu? name)
(make <cpu>
name
(obj-atlist minsn)
(minsn-syntax minsn)
(minsn-compute-iflds (string-append errtxt
- ": " (obj:name minsn))
+ ": " (obj:str-name minsn))
(cddr expn) alias-of)
#f ; ifield-assertion
#f ; semantics
; ptr-to is currently private so there is no accessor.
(define mode:host? (elm-make-getter <mode> 'host?))
-; Return C type to use for values of mode M.
+; Return string C type to use for values of mode M.
(define (mode:c-type m)
(let ((ptr-to (elm-xget m 'ptr-to)))
(if ptr-to
(string-append (mode:c-type ptr-to) " *")
- (obj:name m)))
+ (obj:str-name m)))
)
; CM is short for "concat mode". It is a list of modes of the elements
; Return enum cgen_mode_types value for M.
(define (mode:enum m)
- (gen-c-symbol (string-append "MODE_" (string-upcase (obj:name m))))
+ (gen-c-symbol (string-append "MODE_" (string-upcase (obj:str-name m))))
)
; Return a boolean indicating if MODE1 is equal to MODE2
non-mode-c-type printf-type sem-mode ptr-to host?)
(logit 2 "Processing mode " name " ...\n")
(let* ((name (parse-name name errtxt))
- (errtxt (string-append errtxt " " name))
+ (errtxt (stringsym-append errtxt " " name))
(result (make <mode>
name
(parse-comment comment errtxt)
(define model:units (elm-make-getter <model> 'units))
(define (model:enum m)
- (gen-c-symbol (string-append "MODEL_" (string-upcase (obj:name m))))
+ (gen-c-symbol (string-append "MODEL_" (string-upcase (obj:str-name m))))
)
(define (models-for-mach mach)
(logit 2 "Processing model " name " ...\n")
(let ((name (parse-name name errtxt))
; FIXME: switch to `context' like in cver.
- (errtxt (string-append errtxt " " name))
+ (errtxt (stringsym-append errtxt " " name))
(mach (current-mach-lookup mach-name)))
(if (null? units)
(parse-error errtxt "there must be at least one function unit" name))
(if model
(-insn-timing-parse-model context model
(cdr model-timing-desc))
- ()))))
+ '()))))
insn-timing-desc)
)
\f
" {\n"
" "
"-1, " ; macro-insns are not currently enumerated, no current need to
- "\"" (obj:name minsn) "\", "
+ "\"" (obj:str-name minsn) "\", "
"\"" (minsn-mnemonic minsn) "\",\n"
" " (gen-syntax-entry "MNEM" "OP" (minsn-syntax minsn)) ",\n"
" (PTR) & macro_" (gen-sym minsn) "_expansions[0],\n"
" {\n"
" "
"-1, " ; macro-insns are not currently enumerated, no current need to
- "\"" (obj:name minsn) "\", "
+ "\"" (obj:str-name minsn) "\", "
"\"" (minsn-mnemonic minsn) "\",\n"
" " (gen-syntax-entry "MNEM" "OP" (minsn-syntax minsn)) ",\n"
" (PTR) & macro_" (gen-sym minsn) "_expansions[0],\n"
(lambda (ops)
; OPS is a list of operands with the same name that for whatever reason
; were defined separately.
- (logit 3 (string-append "Processing " (obj:name (car ops)) " " what " ...\n"))
+ (logit 3 (string-append "Processing " (obj:str-name (car ops)) " " what " ...\n"))
(if (= (length ops) 1)
(gen-obj-sanitize
(car ops)
(lambda (self what)
(let ((handlers (elm-get self 'handlers)))
(let ((fn (assq-ref handlers what)))
- (and fn (string-append what "_" (car fn))))))
+ (and fn (string-append (symbol->string what) "_" (car fn))))))
)
; Interface fns.
; it up into manageable chunks.
(define (read-cpu.opc srcdir cpu delim)
- (let ((file (string-append srcdir "/cpu/" (current-arch-name) ".opc"))
+ (let ((file (string-append srcdir "/cpu/"
+ (symbol->string (current-arch-name))
+ ".opc"))
(start-delim (string-append "/* -- " delim))
(end-delim "/* -- "))
(if (file-exists? file)
(method-make!
<operand> 'gen-pretty-name
(lambda (self mode)
- (let* ((name (if (elm-bound? self 'pretty-sem-name) (elm-get self 'pretty-sem-name)
- (if (elm-bound? self 'sem-name) (elm-get self 'sem-name)
- (obj:name self))))
+ (let* ((name (->string (if (elm-bound? self 'pretty-sem-name)
+ (elm-get self 'pretty-sem-name)
+ (if (elm-bound? self 'sem-name)
+ (elm-get self 'sem-name)
+ (obj:name self)))))
(pname (cond ((string=? "h-memory" (string-take 8 name)) "memory")
((string=? "h-" (string-take 2 name)) (string-drop 2 name))
(else name))))
; Assertions of any ifield values or #f if none.
(ifield-assertion . #f)
)
- ())
+ '())
)
(method-make-make! <derived-operand>
; ??? Maybe allow <operand>'s too?
choices
)
- ())
+ '())
)
(define (anyof-operand? x) (class-instance? <anyof-operand> x))
(if (null? op-list)
(error "op-sort: no operands!"))
; First sort by name.
- (let ((sorted-ops (sort op-list
- (lambda (a b)
- (string<? (obj:name a) (obj:name b)))))
- )
+ (let ((sorted-ops (alpha-sort-obj-list op-list)))
(let loop ((result nil)
; Current set of operands with same name.
(this-elm (list (car sorted-ops)))
(define (pgmr-pretty-print-insn-value insn value)
(define (dump-ifield ifld value name-width)
(string-append
- (string-take name-width (obj:name ifld))
+ (string-take name-width (obj:str-name ifld))
": "
(number->string value)
", 0x"
; Builtin macros:
;
-; (.sym symbol1 symbol2 ...) - symbol-append
-; (.str string1 string2 ...) - string-append
+; (.sym symbol1 symbol2 ...) - symbolstr-append
+; (.str string1 string2 ...) - stringsym-append
; (.hex number) - convert to hex string
; (.upcase string) - convert to uppercase
; (.downcase string) - convert to lowercase
; Build a procedure that performs a pmacro expansion.
(define (-pmacro-build-lambda params expansion)
- (eval `(lambda ,params
- (-pmacro-expand ',expansion (-pmacro-env-make ',params (list ,@params)))))
+ (eval1 `(lambda ,params
+ (-pmacro-expand ',expansion (-pmacro-env-make ',params (list ,@params)))))
)
; ??? I'd prefer to use `define-macro', but boot-9.scm uses it and
(define -pmacro-sym
(lambda args
- (apply symbol-append
- (map (lambda (elm)
- (if (number? elm)
- (number->string elm)
- elm))
- args)))
+ (string->symbol
+ (apply string-append
+ (map (lambda (elm)
+ (cond ((number? elm) (number->string elm))
+ ((symbol? elm) (symbol->string elm))
+ ((string? elm) elm)
+ (else
+ (-pmacro-error "invalid argument to .str" elm))))
+ args))))
)
; .str - string-append, auto-convert numbers
(lambda args
(apply string-append
(map (lambda (elm)
- (if (number? elm)
- (number->string elm)
- elm))
+ (cond ((number? elm) (number->string elm))
+ ((symbol? elm) (symbol->string elm))
+ ((string? elm) elm)
+ (else
+ (-pmacro-error "invalid argument to .str" elm))))
args)))
)
; doesn't work, Hobbit creates "eval" variable
;(-pmacro-set! '.eval (-pmacro-make '.eval '(expr) #f eval "eval"))
- (-pmacro-set! '.eval (-pmacro-make '.eval '(expr) #f (eval 'eval) "eval"))
+ (-pmacro-set! '.eval (-pmacro-make '.eval '(expr) #f (eval1 'eval) "eval"))
)
; Initialize so we're ready to use after loading.
(let ((machs (atlist-attr-value-no-default atlist 'MACH obj)))
(if (null? machs)
#t
- (keep-mach? (map string->symbol (string-cut machs #\,)))))
+ (keep-mach? (bitset-attr->list machs))))
)
; Return a boolean indicating if the object containing ATLIST is to be kept.
(define (keep-isa-atlist? atlist obj)
(let ((isas (atlist-attr-value atlist 'ISA obj)))
- (keep-isa? (map string->symbol (string-cut isas #\,))))
+ (keep-isa? (bitset-attr->list isas)))
)
; Return non-#f if object OBJ is to be kept, according to its ISA attribute.
(case (car test)
((keep-isa?)
(if (keep-isa? (cadr test))
- (eval then)
+ (eval1 then)
(if (null? else)
#f
- (eval (car else)))))
+ (eval1 (car else)))))
((keep-mach?)
(if (keep-mach? (cadr test))
- (eval then)
+ (eval1 then)
(if (null? else)
#f
- (eval (car else))))))
+ (eval1 (car else))))))
)
; Top level routine for loading .cpu files.
(method-make!
<c-expr> 'get-name
(lambda (self)
- (string-append "(" (obj:name (elm-get self 'mode)) ") "
+ (string-append "(" (obj:str-name (elm-get self 'mode)) ") "
(cx:c self)))
)
(let ((mode (-rtx-lazy-sem-mode mode)))
(send src 'cxmake-get estate mode #f #f)))
(else
- (error (string-append "operand " (obj:name src)
+ (error (string-append "operand " (obj:str-name src)
" referenced in incompatible mode: ")
(obj:name mode))))))
(cx:make sem-mode
(string-append "(* CGEN_CPU_FPU (current_cpu)->ops->"
(string-downcase name)
- (string-downcase (obj:name sem-mode))
+ (string-downcase (obj:str-name sem-mode))
") (CGEN_CPU_FPU (current_cpu), "
(cx:c val) ")"))
(cx:make sem-mode
- (string-append name (obj:name sem-mode)
+ (string-append name (obj:str-name sem-mode)
" (" (cx:c val) ")")))
(cx:make mode ; not sem-mode on purpose
(string-append "(" c-op " ("
(cx:make sem-mode
(string-append "(* CGEN_CPU_FPU (current_cpu)->ops->"
(string-downcase name)
- (string-downcase (obj:name sem-mode))
+ (string-downcase (obj:str-name sem-mode))
") (CGEN_CPU_FPU (current_cpu), "
(cx:c val1) ", "
(cx:c val2) ")"))
(cx:make sem-mode
- (string-append name (obj:name sem-mode)
+ (string-append name (obj:str-name sem-mode)
" (" (cx:c val1) ", "
(cx:c val2) ")")))
(cx:make mode ; not sem-mode on purpose
(val3 (rtl-c-get estate 'BI src3)))
; FIXME: Argument checking.
(cx:make mode
- (string-append name (obj:name mode)
+ (string-append name (obj:str-name mode)
" ("
(cx:c val1) ", "
(cx:c val2) ", "
(if (-rtx-use-sem-fn? estate c-op mode)
(cx:make sem-mode
- (string-append name (obj:name sem-mode)
+ (string-append name (obj:str-name sem-mode)
" (" (cx:c val1) ", "
(cx:c val2) ")"))
(cx:make mode ; not sem-mode on purpose
(if (and (not (estate-rtl-cover-fns? estate))
(mode:host? (cx:mode s)))
(cx:make mode
- (string-append "((" (obj:name mode) ")"
- " (" (obj:name (cx:mode s)) ")"
+ (string-append "((" (obj:str-name mode) ")"
+ " (" (obj:str-name (cx:mode s)) ")"
" (" (cx:c s) "))"))
(if (or (mode-float? mode)
(mode-float? (cx:mode s)))
(cx:make mode
(string-append "(* CGEN_CPU_FPU (current_cpu)->ops->"
(string-downcase name)
- (string-downcase (obj:name (-rtx-sem-mode (cx:mode s))))
- (string-downcase (obj:name (-rtx-sem-mode mode)))
+ (string-downcase (obj:str-name (-rtx-sem-mode (cx:mode s))))
+ (string-downcase (obj:str-name (-rtx-sem-mode mode)))
") (CGEN_CPU_FPU (current_cpu), "
(cx:c s) ")"))
(cx:make mode
(string-append name
- (obj:name (-rtx-sem-mode (cx:mode s)))
- (obj:name (-rtx-sem-mode mode))
+ (obj:str-name (-rtx-sem-mode (cx:mode s)))
+ (obj:str-name (-rtx-sem-mode mode))
" (" (cx:c s) ")")))))
)
(if (mode-float? mode)
(cx:make (mode:lookup 'BI)
(string-append "(* CGEN_CPU_FPU (current_cpu)->ops->"
- (string-downcase name)
- (string-downcase (obj:name (-rtx-sem-mode mode)))
+ (string-downcase (symbol->string name))
+ (string-downcase (obj:str-name (-rtx-sem-mode mode)))
") (CGEN_CPU_FPU (current_cpu), "
(cx:c val1) ", "
(cx:c val2) ")"))
(cx:make (mode:lookup 'BI)
- (string-append (string-upcase name)
+ (string-append (string-upcase (symbol->string name))
(if (memq name '(eq ne))
- (obj:name (-rtx-sem-mode mode))
- (obj:name mode))
+ (obj:str-name (-rtx-sem-mode mode))
+ (obj:str-name mode))
" (" (cx:c val1) ", "
(cx:c val2) ")")))
(cx:make (mode:lookup 'BI)
(string-append
" "
; ??? mode:c-type
- (string-map (lambda (temp) (string-append (obj:name (cx:mode temp)) " " (cx:c temp) ";"))
+ (string-map (lambda (temp) (string-append (obj:str-name (cx:mode temp))
+ " " (cx:c temp) ";"))
temp-list)
"\n")
)
; Ensure compatible modes.
(apply s-c-raw-call (cons estate
(cons out-mode
- (cons (string-append "JOIN"
- in-mode
- out-mode)
+ (cons (stringsym-append "JOIN"
+ in-mode
+ out-mode)
(cons arg1 arg-rest)))))
)
; Refetch mode in case it was DFLT.
(val-mode (cx:mode val)))
(cx:make mode
- (string-append "SUBWORD" (obj:name val-mode) (obj:name mode)
+ (string-append "SUBWORD"
+ (obj:str-name val-mode) (obj:str-name mode)
" (" (cx:c val)
(if (mode-bigger? val-mode mode)
(string-append
(define (-rtx-option? x)
(and (symbol? x)
- (char=? (string-ref x 0) #\:))
+ (char=? (string-ref (symbol->string x) 0) #\:))
)
; Subroutine of -rtx-munge-mode&options.
#f #f expr
(lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
(display "-expr: ")
- (display (string-append "rtx=" (obj:name rtx-obj)))
+ (display (string-append "rtx=" (obj:str-name rtx-obj)))
(display " expr=")
(display expr)
(display " mode=")
class
'function
(if action
- (eval (list 'lambda (cons '*estate* args) action))
+ (eval1 (list 'lambda (cons '*estate* args) action))
#f)
-rtx-num-next)))
; Add it to the table of rtx handlers.
class
'syntax
(if action
- (eval (list 'lambda (cons '*estate* args) action))
+ (eval1 (list 'lambda (cons '*estate* args) action))
#f)
-rtx-num-next)))
; Add it to the table of rtx handlers.
arg-types arg-modes
class
'operand
- (eval (list 'lambda (cons '*estate* args) action))
+ (eval1 (list 'lambda (cons '*estate* args) action))
-rtx-num-next)))
; Add it to the table of rtx handlers.
(hashq-set! -rtx-func-table name rtx)
(let ((rtx (make <rtx-func> name args #f #f
#f ; class
'macro
- (eval (list 'lambda args action))
+ (eval1 (list 'lambda args action))
-rtx-num-next)))
; Add it to the table of rtx macros.
(hashq-set! -rtx-macro-table name rtx)
locals))
)
-; Return a semi-pretty symbol describing RTX.
+; Return a semi-pretty string describing RTX.
; This is used by hw to include the index in the element's name.
(define (rtx-pretty-name rtx)
(if (pair? rtx)
(case (car rtx)
((const) (number->string (rtx-const-value rtx)))
- ((operand) (obj:name (rtx-operand-obj rtx)))
- ((local) (rtx-local-name rtx))
- ((xop) (obj:name (rtx-xop-obj rtx)))
+ ((operand) (symbol->string (obj:name (rtx-operand-obj rtx))))
+ ((local) (symbol->string (rtx-local-name rtx)))
+ ((xop) (symbol->string (obj:name (rtx-xop-obj rtx))))
(else
(if (null? (cdr rtx))
(car rtx)
- (apply string-append
+ (apply stringsym-append
(cons (car rtx)
(map (lambda (elm)
(string-append "-" (rtx-pretty-name elm)))
(cond ((hw-scalar? hw)
hw-name)
((rtx? index-arg)
- (symbol-append hw-name '- (rtx-pretty-name index-arg)))
+ (symbolstr-append hw-name '- (rtx-pretty-name index-arg)))
(else
- (symbol-append hw-name ; (obj:name (op:type self))
- '-
- ; (obj:name (op:index self)))))
- (stringize index-arg "-"))))
+ (symbolstr-append hw-name ; (obj:name (op:type self))
+ '-
+ ; (obj:name (op:index self)))))
+ (stringize index-arg "-"))))
)
; Return the <operand> object described by
; Drop dummy first arg and sort operand lists.
(let ((sorted-ins
- (sort (map (lambda (op)
- (rtx-xop-obj (cadr op)))
- (cdr in-ops))
- (lambda (a b) (string<? (obj:name a) (obj:name b)))))
+ (alpha-sort-obj-list (map (lambda (op)
+ (rtx-xop-obj (cadr op)))
+ (cdr in-ops))))
(sorted-outs
- (sort (map (lambda (op)
- (rtx-xop-obj (cadr op)))
- (cdr out-ops))
- (lambda (a b) (string<? (obj:name a) (obj:name b)))))
+ (alpha-sort-obj-list (map (lambda (op)
+ (rtx-xop-obj (cadr op)))
+ (cdr out-ops))))
(sem-attrs (cdr sem-attrs)))
(let ((in-op-nums (iota (length sorted-ins)))
(string-write
(gen-c-copyright (string-append "Simulator instruction operand writer for "
- (current-arch-name) ".")
+ (symbol->string (current-arch-name))
+ ".")
copyright-red-hat package-red-hat-simulators)
"\
"used by:")
(string-drop1
(string-map (lambda (user)
- (string-append ", " (obj:name user)))
+ (string-append ", " (obj:str-name user)))
(sfrag-users frag)))
"
(define (unit:enum u)
(gen-c-symbol (string-append "UNIT_"
- (string-upcase (obj:name u))))
+ (string-upcase (obj:str-name u))))
)
; Return C code to define cpu implementation properties.
mode))
(default-selector? (hw-selector-default? selector)))
(cx:make mode
- (string-append "current_cpu->GETMEM" (obj:name mode)
+ (string-append "current_cpu->GETMEM" (obj:str-name mode)
(if default-selector? "" "ASI")
" ("
"pc, "
(hw-mode self)
mode))
(default-selector? (hw-selector-default? selector)))
- (string-append "current_cpu->SETMEM" (obj:name mode)
+ (string-append "current_cpu->SETMEM" (obj:str-name mode)
(if default-selector? "" "ASI")
" ("
"pc, "
(string-append
"const char *mode_names[] = {\n"
(string-map (lambda (m)
- (string-append " \"" (string-upcase (obj:name m)) "\",\n"))
+ (string-append " \"" (string-upcase (obj:str-name m)) "\",\n"))
; We don't treat aliases as being different from the real
; mode here, so ignore them.
(mode-list-non-alias-values))
'(comment "write hardware elements via cover functions/methods"))
; If there is a .sim file, load it.
- (let ((sim-file (string-append srcdir "/cpu/" (current-arch-name) ".sim")))
+ (let ((sim-file (string-append srcdir "/cpu/"
+ (symbol->string (current-arch-name))
+ ".sim")))
(if (file-exists? sim-file)
(begin
(display (string-append "Loading sim file " sim-file " ...\n"))
(cti? (insn-cti? insn))
(insn-len (insn-length-bytes insn)))
(string-list
- "/* " (obj:name insn) ": " (insn-syntax insn) " */\n\n"
+ "/* " (obj:str-name insn) ": " (insn-syntax insn) " */\n\n"
"static SEM_PC\n"
"SEM_FN_NAME (@prefix@," (gen-sym insn) ")"
(if (and parallel? (not (with-generic-write?)))
(cti? (insn-cti? insn))
(insn-len (insn-length-bytes insn)))
(string-list
- "/* " (obj:name insn) ": " (insn-syntax insn) " */\n\n"
+ "/* " (obj:str-name insn) ": " (insn-syntax insn) " */\n\n"
"static SEM_STATUS\n"
"SEM_FN_NAME (@prefix@," (gen-sym insn) ")"
(if (and parallel? (not (with-generic-write?)))
(string-write
(gen-c-copyright (string-append
"ISA definitions header for "
- (obj:name (current-isa))
+ (obj:str-name (current-isa))
".")
CURRENT-COPYRIGHT CURRENT-PACKAGE)
"\
(string-write
(gen-c-copyright (string-append "Simulator instruction operand reader for "
- (current-arch-name) ".")
+ (symbol->string (current-arch-name)) ".")
CURRENT-COPYRIGHT CURRENT-PACKAGE)
"\
#ifdef DEFINE_LABELS
(string-write
(gen-c-copyright (string-append "Simulator instruction operand writer for "
- (current-arch-name) ".")
+ (symbol->string (current-arch-name)) ".")
CURRENT-COPYRIGHT CURRENT-PACKAGE)
"\
/* Write cached results of 1 or more insns executed in parallel. */
(define (unit:enum u)
(gen-c-symbol (string-append "UNIT_"
- (string-upcase (obj:name (unit:model u)))
+ (string-upcase (obj:str-name (unit:model u)))
"_"
- (string-upcase (obj:name u))))
+ (string-upcase (obj:str-name u))))
)
(define (-gen-cpu-imp-properties)
(define (gen-model-fn-decls)
(let ((gen-args (lambda (args)
(gen-c-args (map (lambda (arg)
- (string-append
+ (stringsym-append
(mode:c-type (mode:lookup (cadr arg)))
" /*" (car arg) "*/"))
(find (lambda (arg)
(string-list-map
(lambda (model)
(string-list-map (lambda (unit)
- (string-append
+ (stringsym-append
"extern int "
(gen-model-unit-fn-name model unit)
" (SIM_CPU *, const IDESC *,"
(define (-gen-model-timing-table model)
(string-write
- "/* Model timing data for `" (obj:name model) "'. */\n\n"
+ "/* Model timing data for `" (obj:str-name model) "'. */\n\n"
"static const INSN_TIMING " (gen-sym model) "_timing[] = {\n"
(lambda () (string-write-map (lambda (insn) (-gen-insn-timing model insn))
(non-alias-insns (current-insn-list))))
static const MODEL " (gen-sym mach) "_models[] =\n{\n"
(string-list-map (lambda (model)
(string-list " { "
- "\"" (obj:name model) "\", "
+ "\"" (obj:str-name model) "\", "
"& " (gen-sym (model:mach model)) "_mach, "
(model:enum model) ", "
"TIMING_DATA (& "
const MACH " (gen-sym mach) "_mach =
{
- \"" (obj:name mach) "\", "
+ \"" (obj:str-name mach) "\", "
"\"" (mach-bfd-name mach) "\", "
(mach-enum mach) ",\n"
" " (number->string (cpu-word-bitsize (mach-cpu mach))) ", "
; ??? Could just call this gen-set as there is no gen-set-trace
; but for consistency with the messages passed to operands
; we use this same.
-; gen-type - C type to use to record value.
+; gen-type - C type to use to record value, as a string.
; ??? Delete and just use get-mode?
; save-index? - return #t if an index needs to be saved for parallel
; execution post-write processing
(define (gen-reg-access-defn hw prefix type scalar? get-code set-code)
(string-append
- "/* Get the value of " (obj:name hw) ". */\n\n"
+ "/* Get the value of " (obj:str-name hw) ". */\n\n"
type "\n"
(gen-reg-getter-fn hw prefix)
" (SIM_CPU *current_cpu"
")\n{\n"
get-code
"}\n\n"
- "/* Set a value for " (obj:name hw) ". */\n\n"
+ "/* Set a value for " (obj:str-name hw) ". */\n\n"
"void\n"
(gen-reg-setter-fn hw prefix)
" (SIM_CPU *current_cpu, "
mode))
(default-selector? (hw-selector-default? selector)))
(cx:make mode
- (string-append "GETMEM" (obj:name mode)
+ (string-append "GETMEM" (obj:str-name mode)
(if default-selector? "" "ASI")
" ("
"current_cpu, pc, "
(hw-mode self)
mode))
(default-selector? (hw-selector-default? selector)))
- (string-append "SETMEM" (obj:name mode)
+ (string-append "SETMEM" (obj:str-name mode)
(if default-selector? "" "ASI")
" ("
"current_cpu, pc, "
(string-append
"const char *mode_names[] = {\n"
(string-map (lambda (m)
- (string-append " \"" (string-upcase (obj:name m)) "\",\n"))
+ (string-append " \"" (string-upcase (obj:str-name m)) "\",\n"))
; We don't treat aliases as being different from the real
; mode here, so ignore them.
(mode-list-non-alias-values))
(define-full-insn 'x-begin "pbb begin handler"
`(VIRTUAL PBB (ISA ,all))
- "--begin--" () () '(c-code VOID "\
+ "--begin--" '() '() '(c-code VOID "\
{
#if WITH_SCACHE_PBB_@PREFIX@
#if defined DEFINE_SWITCH || defined FAST_P
(define-full-insn 'x-chain "pbb chain handler"
`(VIRTUAL PBB (ISA ,all))
- "--chain--" () () '(c-code VOID "\
+ "--chain--" '() '() '(c-code VOID "\
{
#if WITH_SCACHE_PBB_@PREFIX@
vpc = @prefix@_pbb_chain (current_cpu, sem_arg);
(define-full-insn 'x-cti-chain "pbb cti-chain handler"
`(VIRTUAL PBB (ISA ,all))
- "--cti-chain--" () () '(c-code VOID "\
+ "--cti-chain--" '() '() '(c-code VOID "\
{
#if WITH_SCACHE_PBB_@PREFIX@
#ifdef DEFINE_SWITCH
(define-full-insn 'x-before "pbb begin handler"
`(VIRTUAL PBB (ISA ,all))
- "--before--" () () '(c-code VOID "\
+ "--before--" '() '() '(c-code VOID "\
{
#if WITH_SCACHE_PBB_@PREFIX@
@prefix@_pbb_before (current_cpu, sem_arg);
(define-full-insn 'x-after "pbb after handler"
`(VIRTUAL PBB (ISA ,all))
- "--after--" () () '(c-code VOID "\
+ "--after--" '() '() '(c-code VOID "\
{
#if WITH_SCACHE_PBB_@PREFIX@
@prefix@_pbb_after (current_cpu, sem_arg);
(define-full-insn 'x-invalid "invalid insn handler"
`(VIRTUAL (ISA ,all))
- "--invalid--" () () (list 'c-code 'VOID (string-append "\
+ "--invalid--" '() '() (list 'c-code 'VOID (string-append "\
{
/* Update the recorded pc in the cpu state struct.
Only necessary for WITH_SCACHE case, but to avoid the
; Each named entry in the description file typically has these three members:
; name, comment attrs.
-(define <ident> (class-make '<ident> () '(name comment attrs) ()))
+(define <ident> (class-make '<ident> '() '(name comment attrs) '()))
(method-make! <ident> 'get-name (lambda (self) (elm-get self 'name)))
(method-make! <ident> 'get-comment (lambda (self) (elm-get self 'comment)))
(define (obj-set-name! obj name) (send obj 'set-name! name))
(define (obj:comment obj) (send obj 'get-comment))
+; Utility to return the name as a string.
+
+(define (obj:str-name obj) (symbol->string (obj:name obj)))
+
; Utility to add standard access methods for name, comment, attrs.
; ??? Old. Using <ident> baseclass now.
(cond ((list? comment)
(string-map (lambda (elm) (parse-comment elm errtxt)) comment))
((or (string? comment) (symbol? comment))
- comment)
+ (->string comment))
(else (parse-error errtxt "improper comment" comment)))
)
(define (parse-symbol context value)
(if (and (not (symbol? value)) (not (string? value)))
- (parse-error context "not a symbol" value))
- value
+ (parse-error context "not a symbol or string" value))
+ (->symbol value)
)
; Parse a string.
(define (parse-string context value)
(if (and (not (symbol? value)) (not (string? value)))
- (parse-error context "not a string" value))
- value
+ (parse-error context "not a string or symbol" value))
+ (->string value)
)
; Parse a number.
(not (null? x))
(or (keyword? (car x))
(and (symbol? (car x))
- (char=? (string-ref (car x) 0) #\:))))
+ (char=? (string-ref (symbol->string (car x)) 0) #\:))))
)
; Convert a list like (#:key1 val1 #:key2 val2 ...) to
nil
(cdr rkl)))
((and (symbol? (car rkl))
- (char=? (string-ref (car rkl) 0) #\:))
+ (char=? (string-ref (symbol->string (car rkl)) 0) #\:))
(loop (acons (string->symbol
(substring (car rkl) 1 (string-length (car rkl))))
current result)
; PREFIX is the prefix arg to gen-attr-enum-decl.
(define (gen-attr-name prefix attr-name)
- (string-upcase (gen-c-symbol (string-append prefix "_" attr-name)))
+ (string-upcase (gen-c-symbol (string-append prefix "_"
+ (symbol->string attr-name))))
)
; Normal gen-mask argument to gen-bool-attrs.
(define (alpha-sort-obj-list l)
(sort l
(lambda (o1 o2)
- (string<? (obj:name o1) (obj:name o2))))
+ (symbol<? (obj:name o1) (obj:name o2))))
)
\f
; Called before loading the .cpu file to initialize.
(define (attr-gen-decl attr)
(gen-enum-decl (symbol-append (obj:name attr) '-attr)
(obj:comment attr)
- (string-append (obj:name attr) "_")
+ (string-append (obj:str-name attr) "_")
(attr-values attr))
)
(string-list indent macro-name
" /*"
(string-list-map (lambda (fld)
- (string-append " " (obj:name fld)))
+ (string-append " " (obj:str-name fld)))
ifields)
" */\n")
(let ((indent (if macro? (string-append indent " ") indent)))
(in-ops (sfmt-in-ops sfmt))
(out-ops (sfmt-out-ops sfmt))
(sort-elms (lambda (a b)
- ; Sort by descending size, then ascending C type, then
- ; ascending name.
+ ; Sort by descending size, then ascending C type name,
+ ; then ascending name.
(cond ((> (caddr a) (caddr b))
#t)
((= (caddr a) (caddr b))
)
(logit 4
"-sfmt-contents sfmt=" (obj:name sfmt)
- " needed-iflds=" (string-map obj:name needed-iflds)
- " extracted-ops=" (string-map obj:name extracted-ops)
- " in-ops=" (string-map obj:name in-ops)
- " out-ops=" (string-map obj:name out-ops)
+ " needed-iflds=" (string-map obj:str-name needed-iflds)
+ " extracted-ops=" (string-map obj:str-name extracted-ops)
+ " in-ops=" (string-map obj:str-name in-ops)
+ " out-ops=" (string-map obj:str-name out-ops)
"\n")
(cons sfmt
(sort
(define (collect fn . args) (apply append (apply map (cons fn args))))
-
; Map over value entries in an alist.
; 'twould be nice if this were a primitive.
(fn l))))))
)
-; Turn STR into a proper C symbol.
+; Turn string or symbol STR into a proper C symbol.
+; The result is a string.
; We assume STR has no leading digits.
; All invalid characters are turned into '_'.
; FIXME: Turn trailing "?" into "_p".
(define (gen-c-symbol str)
(if (not (or (string? str) (symbol? str)))
(error "gen-c-symbol: not symbol or string:" str))
- (map-over-string (lambda (c) (if (id-char? c) c #\_)) str)
+ (map-over-string (lambda (c) (if (id-char? c) c #\_))
+ (->string str))
)
-; Turn STR into a proper file name, which is defined to be the same
-; as gen-c-symbol except use -'s instead of _'s.
+; Turn string or symbol STR into a proper file name, which is
+; defined to be the same as gen-c-symbol except use -'s instead of _'s.
+; The result is a string.
(define (gen-file-name str)
(if (not (or (string? str) (symbol? str)))
(error "gen-file-name: not symbol or string:" str))
- (map-over-string (lambda (c) (if (id-char? c) c #\-)) str)
+ (map-over-string (lambda (c) (if (id-char? c) c #\-))
+ (->string str))
)
; Turn STR into lowercase.
(map-over-string (lambda (c) (char-upcase c)) str)
)
+; Turn SYM into lowercase.
+
+(define (symbol-downcase sym)
+ (string->symbol (string-downcase (symbol->string sym)))
+)
+
+; Turn SYM into uppercase.
+
+(define (symbol-upcase sym)
+ (string->symbol (string-upcase (symbol->string sym)))
+)
+
+; Symbol sorter.
+
+(define (symbol<? a b)
+ (string<? (symbol->string a) (symbol->string b))
+)
+
; Drop N chars from string S.
; If N is negative, drop chars from the end.
; It is ok to drop more characters than are in the string, the result is "".
l)))
(else (error "stringize: can't handle:" l)))
)
+
+; Same as string-append, but accepts symbols too.
+; PERF: This implementation may be unacceptably slow. Revisit.
+
+(define stringsym-append
+ (lambda args
+ (apply string-append
+ (map (lambda (s)
+ (if (symbol? s)
+ (symbol->string s)
+ s))
+ args)))
+)
+
+; Same as symbol-append, but accepts strings too.
+
+(define symbolstr-append
+ (lambda args
+ (string->symbol (apply stringsym-append args)))
+)
+
+; Given a symbol or a string, return the string form.
+
+(define (->string s)
+ (if (symbol? s)
+ (symbol->string s)
+ s)
+)
+
+; Given a symbol or a string, return the symbol form.
+
+(define (->symbol s)
+ (if (string? s)
+ (string->symbol s)
+ s)
+)
\f
; Output routines.
; Return #t if each element of bools is #t. Since Scheme considers any
; non-#f value as #t we do too.
-; (all-true? ()) is #t since that is the identity element.
+; (all-true? '()) is #t since that is the identity element.
(define (all-true? bools)
(cond ((null? bools) #t)
(if (number? x)
x
; A symbol bound to a number?
- (if (and (symbol? x) (symbol-bound? #f x) (number? (eval x)))
- (eval x)
+ (if (and (symbol? x) (symbol-bound? #f x) (number? (eval1 x)))
+ (eval1 x)
; An enum value that has a known numeric value?
(let ((e (enum-lookup-val x)))
(if (number? (car e))
OSDN Git Service
