cgen/utils-cgen.scm

   1 ; CGEN Utilities.
   2 ; Copyright (C) 2000, 2002, 2003, 2009 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5 ;
   6 ; This file contains utilities specific to cgen.
   7 ; Generic utilities should go in utils.scm.
   8
   9 ; True if text of sanitize markers are to be emitted.
  10 ; This is a debugging tool only, though it could have use in sanitized trees.
  11 (define include-sanitize-marker? #t)
  12
  13 ; Utility to display command line invocation for debugging purposes.
  14
  15 (define (display-argv argv)
  16   (let ((cep (current-error-port)))
  17     (display "cgen -s " cep)
  18     (for-each (lambda (arg)
  19                 ; Output double-quotes if string has a space for better
  20                 ; correspondence to how to specify string to shell.
  21                 (if (string-index arg #\space)
  22                     (write arg cep)
  23                     (display arg cep))
  24                 (display " " cep))
  25               argv)
  26     (newline cep))
  27 )
  28 \f
  29 ; COS utilities.
  30 ; Perhaps these should be provided with cos (cgen-object-system), but for
  31 ; now they live here.
  32
  33 ; Define the getter for a list of elements of a class.
  34
  35 (defmacro define-getters (class class-prefix elm-names)
  36   (cons 'begin
  37         (map (lambda (elm-name)
  38                (if (pair? elm-name)
  39                    `(define ,(symbol-append class-prefix '- (cdr elm-name))
  40                       (elm-make-getter ,class (quote ,(car elm-name))))
  41                    `(define ,(symbol-append class-prefix '- elm-name)
  42                       (elm-make-getter ,class (quote ,elm-name)))))
  43              elm-names))
  44 )
  45
  46 ; Define the setter for a list of elements of a class.
  47
  48 (defmacro define-setters (class class-prefix elm-names)
  49   (cons 'begin
  50         (map (lambda (elm-name)
  51                (if (pair? elm-name)
  52                    `(define ,(symbol-append class-prefix '-set- (cdr elm-name) '!)
  53                       (elm-make-setter ,class (quote ,(car elm-name))))
  54                    `(define ,(symbol-append class-prefix '-set- elm-name '!)
  55                       (elm-make-setter ,class (quote ,elm-name)))))
  56              elm-names))
  57 )
  58
  59 ; Make an object, specifying values for particular elements.
  60 ; ??? Eventually move to cos.scm/cos.c.
  61
  62 (define (vmake class . args)
  63   (let ((obj (new class)))
  64     (let ((unrecognized (send obj 'vmake! args)))
  65       (if (null? unrecognized)
  66           obj
  67           (error "vmake: unknown options:" unrecognized))))
  68 )
  69 \f
  70 ;;; Source locations are recorded as a stack, with (ideally) one extra level
  71 ;;; for each macro invocation.
  72
  73 (define <location> (class-make '<location>
  74                                nil
  75                                '(
  76                                  ;; A list of "single-location" objects,
  77                                  ;; sorted by most recent location first.
  78                                  list
  79                                  )
  80                                nil))
  81
  82 (define-getters <location> location (list))
  83 (define-setters <location> location (list))
  84
  85 ;;; A single source location.
  86 ;;; This is recorded as a vector for simplicity.
  87 ;;; END? is true if the location marks the end of the expression.
  88 ;;; NOTE: LINE and COLUMN are origin-0 (the first line is line 0).
  89
  90 (define (make-single-location file line column end?)
  91   (vector file line column end?)
  92 )
  93
  94 (define (single-location-file sloc) (vector-ref sloc 0))
  95 (define (single-location-line sloc) (vector-ref sloc 1))
  96 (define (single-location-column sloc) (vector-ref sloc 2))
  97 (define (single-location-end? sloc) (vector-ref sloc 3))
  98
  99 ;;; Return a single-location in a readable form.
 100
 101 (define (single-location->string sloc)
 102   ;; +1: numbers are recorded origin-0
 103   (string-append (single-location-file sloc)
 104                  ":"
 105                  (number->string (+ (single-location-line sloc) 1))
 106                  ":"
 107                  (number->string (+ (single-location-column sloc) 1))
 108                  (if (single-location-end? sloc) "(end)" ""))
 109 )
 110
 111 ;;; Same as single-location->string, except omit any directory info in
 112 ;;; the file name.
 113
 114 (define (single-location->simple-string sloc)
 115   ;; +1: numbers are recorded origin-0
 116   (string-append (basename (single-location-file sloc))
 117                  ":"
 118                  (number->string (+ (single-location-line sloc) 1))
 119                  ":"
 120                  (number->string (+ (single-location-column sloc) 1))
 121                  (if (single-location-end? sloc) "(end)" ""))
 122 )
 123
 124 ;;; Return a location in a readable form.
 125
 126 (define (location->string loc)
 127   (let ((ref-from " referenced from:"))
 128     (string-drop
 129      (- 0 (string-length ref-from) 1)
 130      (string-drop1
 131       (apply string-append
 132              (map (lambda (sloc)
 133                     (string-append "\n"
 134                                    (single-location->string sloc)
 135                                    ":"
 136                                    ref-from))
 137                   (location-list loc))))))
 138 )
 139
 140 ;;; Return the location information in Guile's source-properties
 141 ;;; in a readable form.
 142
 143 (define (source-properties-location->string src-props)
 144   (let ((file (assq-ref src-props 'filename))
 145         (line (assq-ref src-props 'line))
 146         (column (assq-ref src-props 'column)))
 147     (string-append file
 148                    ":"
 149                    (number->string (+ line 1))
 150                    ":"
 151                    (number->string (+ column 1))))
 152 )
 153
 154 ;;; Return the top location on LOC's stack.
 155
 156 (define (location-top loc)
 157   (car (location-list loc))
 158 )
 159
 160 ;;; Return a new <location> with FILE, LINE pushed onto the stack.
 161
 162 (define (location-push-single loc file line column end?)
 163   (make <location> (cons (make-single-location file line column end?)
 164                          (location-list loc)))
 165 )
 166
 167 ;;; Return a new <location> with NEW-LOC preappended to LOC.
 168
 169 (define (location-push loc new-loc)
 170   (make <location> (append (location-list new-loc)
 171                            (location-list loc)))
 172 )
 173
 174 ;;; Return an unspecified <location>.
 175 ;;; This is mainly for use in debugging utilities.
 176 ;;; Ideally for .cpu-file related stuff we always have a location,
 177 ;;; but that's not always true.
 178
 179 (define (unspecified-location)
 180   (make <location> (list (make-single-location "unspecified" 0 0 #f)))
 181 )
 182
 183 ;;; Return a <location> object for the current input port.
 184 ;;; END? is true if the location marks the end of the expression.
 185
 186 (define (current-input-location end?)
 187   (let ((cip (current-input-port)))
 188     (make <location> (list (make-single-location (port-filename cip)
 189                                                  (port-line cip)
 190                                                  (port-column cip)
 191                                                  end?))))
 192 )
 193
 194 ;;; An object property for tracking source locations during macro expansion.
 195
 196 (define location-property (make-object-property))
 197
 198 ;;; Set FORM's location to LOC.
 199
 200 (define (location-property-set! form loc)
 201   (set! (location-property form) loc)
 202   *UNSPECIFIED*
 203 )
 204 \f
 205 ; Each named entry in the description file typically has these three members:
 206 ; name, comment attrs.
 207
 208 (define <ident> (class-make '<ident> '() '(name comment attrs) '()))
 209
 210 (method-make! <ident> 'get-name (lambda (self) (elm-get self 'name)))
 211 (method-make! <ident> 'get-comment (lambda (self) (elm-get self 'comment)))
 212 (method-make! <ident> 'get-atlist (lambda (self) (elm-get self 'attrs)))
 213
 214 (method-make! <ident> 'set-name!
 215               (lambda (self newval) (elm-set! self 'name newval)))
 216 (method-make! <ident> 'set-comment!
 217               (lambda (self newval) (elm-set! self 'comment newval)))
 218 (method-make! <ident> 'set-atlist!
 219               (lambda (self newval) (elm-set! self 'attrs newval)))
 220
 221 ; All objects defined in the .cpu file have these elements.
 222 ; Where in the class hierarchy they're recorded depends on the object.
 223 ; Additionally most objects have `name', `comment' and `attrs' elements.
 224
 225 (define (obj:name obj) (send obj 'get-name))
 226 (define (obj-set-name! obj name) (send obj 'set-name! name))
 227 (define (obj:comment obj) (send obj 'get-comment))
 228
 229 ; Utility to return the name as a string.
 230
 231 (define (obj:str-name obj) (symbol->string (obj:name obj)))
 232
 233 ; Subclass of <ident> for use by description file objects.
 234 ;
 235 ; Records the source location of the object.
 236 ;
 237 ; We also record an internally generated entry, ordinal, to record the
 238 ; relative position within the description file.  It's generally more efficient
 239 ; to record some kinds of objects (e.g. insns) in a hash table.  But we also
 240 ; want to emit these objects in file order.  Recording the object's relative
 241 ; position lets us generate an ordered list when we need to.
 242 ; We can't just use the line number because we want an ordering over multiple
 243 ; input files.
 244
 245 (define <source-ident>
 246   (class-make '<source-ident> '(<ident>)
 247               '(
 248                 ;; A <location> object.
 249                 (location . ())
 250                 ;; #f for ordinal means "unassigned"
 251                 (ordinal . #f)
 252                 )
 253               '()))
 254
 255 (method-make! <source-ident> 'get-location
 256               (lambda (self) (elm-get self 'location)))
 257 (method-make! <source-ident> 'set-location!
 258               (lambda (self newval) (elm-set! self 'location newval)))
 259 (define (obj-location obj) (send obj 'get-location))
 260 (define (obj-set-location! obj location) (send obj 'set-location! location))
 261
 262 (method-make! <source-ident> 'get-ordinal
 263               (lambda (self) (elm-get self 'ordinal)))
 264 (method-make! <source-ident> 'set-ordinal!
 265               (lambda (self newval) (elm-set! self 'ordinal newval)))
 266 (define (obj-ordinal obj) (send obj 'get-ordinal))
 267 (define (obj-set-ordinal! obj ordinal) (send obj 'set-ordinal! ordinal))
 268 \f
 269 ; Parsing utilities
 270
 271 ;;; A parsing/processing context, used to give better error messages.
 272 ;;; LOCATION must be an object created with make-location.
 273
 274 (define <context>
 275   (class-make '<context> nil
 276               '(
 277                 ;; Location of the object being processed,
 278                 ;; or #f if unknown (or there is none).
 279                 (location . #f)
 280                 ;; Error message prefix or #f if there is none.
 281                 (prefix . #f)
 282                 )
 283               nil)
 284 )
 285
 286 ; Accessors.
 287
 288 (define-getters <context> context (location prefix))
 289
 290 ; Create a <context> object that is just a prefix.
 291
 292 (define (make-prefix-context prefix)
 293   (make <context> #f prefix)
 294 )
 295
 296 ; Create a <context> object that (current-reader-location) with PREFIX.
 297
 298 (define (make-current-context prefix)
 299   (make <context> (current-reader-location) prefix)
 300 )
 301
 302 ; Create a new context from CONTEXT with TEXT appended to the prefix.
 303
 304 (define (context-append context text)
 305   (make <context> (context-location context)
 306         (string-append (context-prefix context) text))
 307 )
 308
 309 ; Create a new context from CONTEXT with NAME appended to the prefix.
 310
 311 (define (context-append-name context name)
 312   (context-append context (stringsym-append ":" name))
 313 )
 314
 315 ; Call this to issue an error message.
 316 ; CONTEXT is a <context> object or #f if there is none.
 317 ; ARG is the value that had the error if there is one.
 318
 319 (define (context-error context errmsg . arg)
 320   (cond ((and context (context-location context))
 321          (let ((msg (string-append
 322                      "@ "
 323                      (location->string (context-location context))
 324                      ": "
 325                      (context-prefix context) ": "
 326                      errmsg ": ")))
 327            (apply error (cons msg arg))))
 328         (context (let ((msg (string-append (context-prefix context) ": "
 329                                            errmsg ": ")))
 330                    (apply error (cons msg arg))))
 331         (else (apply error (cons (string-append errmsg ": ") arg))))
 332 )
 333
 334 ; Parse an object name.
 335 ; NAME is either a symbol or a list of symbols which are concatenated
 336 ; together.  Each element can in turn be a list of symbols, and so on.
 337 ; This supports symbol concatenation in the description file without having
 338 ; to using string-append or some such.
 339
 340 (define (parse-name context name)
 341   (string->symbol
 342    (let parse ((name name))
 343      (cond
 344       ((symbol? name) (symbol->string name))
 345       ((string? name) name)
 346       ((number? name) (number->string name))
 347       ((list? name) (string-map parse name))
 348       (else (parse-error context "improper name" name)))))
 349 )
 350
 351 ; Parse an object comment.
 352 ; COMMENT is either a string or a list of strings, each element of which may
 353 ; in turn be a list of strings.
 354
 355 (define (parse-comment context comment)
 356   (cond ((string? comment) comment)
 357         ((symbol? comment) (symbol->string comment))
 358         ((number? comment) (number->string comment))
 359         ((list? comment)
 360          (string-map (lambda (elm) (parse-comment context elm)) comment))
 361         (else (parse-error context "improper comment" comment)))
 362 )
 363
 364 ; Parse a symbol.
 365
 366 (define (parse-symbol context value)
 367   (if (and (not (symbol? value)) (not (string? value)))
 368       (parse-error context "not a symbol or string" value))
 369   (->symbol value)
 370 )
 371
 372 ; Parse a string.
 373
 374 (define (parse-string context value)
 375   (if (and (not (symbol? value)) (not (string? value)))
 376       (parse-error context "not a string or symbol" value))
 377   (->string value)
 378 )
 379
 380 ; Parse a number.
 381 ; VALID-VALUES is a list of numbers and (min . max) pairs.
 382
 383 (define (parse-number context value . valid-values)
 384   (if (not (number? value))
 385       (parse-error context "not a number" value))
 386   (if (any-true? (map (lambda (test)
 387                         (if (pair? test)
 388                             (and (>= value (car test))
 389                                  (<= value (cdr test)))
 390                             (= value test)))
 391                       valid-values))
 392       value
 393       (parse-error context "invalid number" value valid-values))
 394 )
 395
 396 ; Parse a boolean value
 397
 398 (define (parse-boolean context value)
 399   (if (boolean? value)
 400       value
 401       (parse-error context "not a boolean (#f/#t)" value))
 402 )
 403
 404 ; Parse a list of handlers.
 405 ; Each entry is (symbol "string").
 406 ; These map function to a handler for it.
 407 ; The meaning is up to the application but generally the handler is a
 408 ; C/C++ function name.
 409 ; ALLOWED is a list valid values for the symbol or #f if anything is allowed.
 410 ; The result is handlers unchanged.
 411
 412 (define (parse-handlers context allowed handlers)
 413   (if (not (list? handlers))
 414       (parse-error context "bad handler spec" handlers))
 415   (for-each (lambda (arg)
 416               (if (not (list-elements-ok? arg (list symbol? string?)))
 417                   (parse-error context "bad handler spec" arg))
 418               (if (and allowed (not (memq (car arg) allowed)))
 419                   (parse-error context "unknown handler type" (car arg))))
 420             handlers)
 421   handlers
 422 )
 423
 424 ; Return a boolean indicating if X is a keyword.
 425 ; This also handles symbols named :foo because Guile doesn't stablely support
 426 ; :keywords (how does one enable :keywords? read-options doesn't appear to
 427 ; work).
 428
 429 (define (keyword-list? x)
 430   (and (list? x)
 431        (not (null? x))
 432        (or (keyword? (car x))
 433            (and (symbol? (car x))
 434                 (char=? (string-ref (symbol->string (car x)) 0) #\:))))
 435 )
 436
 437 ; Convert a list like (#:key1 val1 #:key2 val2 ...) to
 438 ; ((#:key1 val1) (#:key2 val2) ...).
 439 ; Missing values are specified with an empty list.
 440 ; This also supports (:sym1 val1 ...) because Guile doesn't stablely support
 441 ; :keywords (#:keywords work, but #:foo shouldn't appear in the description
 442 ; language).
 443
 444 (define (keyword-list->arg-list kl)
 445   ; Scan KL backwards, building up each element as we go.
 446   (let loop ((result nil) (current nil) (rkl (reverse kl)))
 447     (cond ((null? rkl)
 448            result)
 449           ((keyword? (car rkl))
 450            (loop (acons (keyword->symbol (car rkl)) current result)
 451                  nil
 452                  (cdr rkl)))
 453           ((and (symbol? (car rkl))
 454                 (char=? (string-ref (symbol->string (car rkl)) 0) #\:))
 455            (loop (acons (string->symbol
 456                          (substring (car rkl) 1 (string-length (car rkl))))
 457                         current result)
 458                  nil
 459                  (cdr rkl)))
 460           (else
 461            (loop result
 462                  (cons (car rkl) current)
 463                  (cdr rkl)))))
 464 )
 465
 466 ; Signal an error if the argument name is not a symbol.
 467 ; This is done by each of the argument validation routines so the caller
 468 ; doesn't need to make two calls.
 469
 470 (define (arg-list-validate-name context arg-spec)
 471   (if (null? arg-spec)
 472       (parse-error context "empty argument spec" arg-spec))
 473   (if (not (symbol? (car arg-spec)))
 474       (parse-error context "argument name not a symbol" arg-spec))
 475   *UNSPECIFIED*
 476 )
 477
 478 ; Signal a parse error if an argument was specified with a value.
 479 ; ARG-SPEC is (name value).
 480
 481 (define (arg-list-check-no-args context arg-spec)
 482   (arg-list-validate-name context arg-spec)
 483   (if (not (null? (cdr arg-spec)))
 484       (parse-error context (string-append (car arg-spec)
 485                                           " takes zero arguments")))
 486   *UNSPECIFIED*
 487 )
 488
 489 ; Validate and return a symbol argument.
 490 ; ARG-SPEC is (name value).
 491
 492 (define (arg-list-symbol-arg context arg-spec)
 493   (arg-list-validate-name context arg-spec)
 494   (if (or (!= (length (cdr arg-spec)) 1)
 495           (not (symbol? (cadr arg-spec))))
 496       (parse-error context (string-append (car arg-spec)
 497                                           ": argument not a symbol")))
 498   (cadr arg-spec)
 499 )
 500 \f
 501 ; Sanitization
 502
 503 ; Sanitization is handled via attributes.  Anything that must be sanitized
 504 ; has a `sanitize' attribute with the value being the keyword to sanitize on.
 505 ; Ideally most, if not all, of the guts of the generated sanitization is here.
 506
 507 ; Utility to simplify expression in .cpu file.
 508 ; Usage: (sanitize keyword entry-type entry-name1 [entry-name2 ...])
 509 ; Enum attribute `(sanitize keyword)' is added to the entry.
 510 ; It's written this way so Hobbit can handle it.
 511
 512 (define (sanitize keyword entry-type . entry-names)
 513   (for-each (lambda (entry-name)
 514               (let ((entry #f))
 515                 (case entry-type
 516                   ((attr) (set! entry (current-attr-lookup entry-name)))
 517                   ((enum) (set! entry (current-enum-lookup entry-name)))
 518                   ((isa) (set! entry (current-isa-lookup entry-name)))
 519                   ((cpu) (set! entry (current-cpu-lookup entry-name)))
 520                   ((mach) (set! entry (current-mach-lookup entry-name)))
 521                   ((model) (set! entry (current-model-lookup entry-name)))
 522                   ((ifield) (set! entry (current-ifld-lookup entry-name)))
 523                   ((hardware) (set! entry (current-hw-lookup entry-name)))
 524                   ((operand) (set! entry (current-op-lookup entry-name)))
 525                   ((insn) (set! entry (current-insn-lookup entry-name)))
 526                   ((macro-insn) (set! entry (current-minsn-lookup entry-name)))
 527                   (else (parse-error (make-prefix-context "sanitize")
 528                                      "unknown entry type" entry-type)))
 529
 530                 ; ENTRY is #f in the case where the element was discarded
 531                 ; because its mach wasn't selected.  But in the case where
 532                 ; we're keeping everything, ensure ENTRY is not #f to
 533                 ; catch spelling errors.
 534
 535                 (if entry
 536
 537                     (begin
 538                       (obj-cons-attr! entry (enum-attr-make 'sanitize keyword))
 539                       ; Propagate the sanitize attribute to class members
 540                       ; as necessary.
 541                       (case entry-type
 542                         ((hardware)
 543                          (if (hw-indices entry)
 544                              (obj-cons-attr! (hw-indices entry)
 545                                              (enum-attr-make 'sanitize
 546                                                              keyword)))
 547                          (if (hw-values entry)
 548                              (obj-cons-attr! (hw-values entry)
 549                                              (enum-attr-make 'sanitize
 550                                                              keyword))))
 551                         ))
 552
 553                     (if (and (eq? APPLICATION 'OPCODES) (keep-all?))
 554                         (parse-error (make-prefix-context "sanitize")
 555                                      (string-append "unknown " entry-type)
 556                                      entry-name)))))
 557             entry-names)
 558
 559   #f ; caller eval's our result, so return a no-op
 560 )
 561
 562 ; Return TEXT sanitized with KEYWORD.
 563 ; TEXT must exist on a line (or lines) by itself.
 564 ; i.e. it is assumed that it begins at column 1 and ends with a newline.
 565 ; If KEYWORD is #f, no sanitization is generated.
 566
 567 (define (gen-sanitize keyword text)
 568   (cond ((null? text) "")
 569         ((pair? text) ; pair? -> cheap list?
 570          (if (and keyword include-sanitize-marker?)
 571              (string-list
 572               ; split string to avoid removal
 573               "/* start-"
 574               "sanitize-" keyword " */\n"
 575               text
 576               "/* end-"
 577               "sanitize-" keyword " */\n")
 578              text))
 579         (else
 580          (if (= (string-length text) 0)
 581              ""
 582              (if (and keyword include-sanitize-marker?)
 583                  (string-append
 584                   ; split string to avoid removal
 585                   "/* start-"
 586                   "sanitize-" keyword " */\n"
 587                   text
 588                   "/* end-"
 589                   "sanitize-" keyword " */\n")
 590                  text))))
 591 )
 592
 593 ; Return TEXT sanitized with OBJ's sanitization, if it has any.
 594 ; OBJ may be #f.
 595
 596 (define (gen-obj-sanitize obj text)
 597   (if obj
 598       (let ((san (obj-attr-value obj 'sanitize)))
 599         (gen-sanitize (if (or (not san) (eq? san 'none)) #f san)
 600                       text))
 601       (gen-sanitize #f text))
 602 )
 603 \f
 604 ; Cover procs to handle generation of object declarations and definitions.
 605 ; All object output should be routed through gen-decl and gen-defn.
 606
 607 ; Send the gen-decl message to OBJ, and sanitize the output if necessary.
 608
 609 (define (gen-decl obj)
 610   (logit 3 "Generating decl for "
 611          (cond ((method-present? obj 'get-name) (send obj 'get-name))
 612                ((elm-present? obj 'name) (elm-get obj 'name))
 613                (else "unknown"))
 614          " ...\n")
 615   (cond ((and (method-present? obj 'gen-decl) (not (has-attr? obj 'META)))
 616          (gen-obj-sanitize obj (send obj 'gen-decl)))
 617         (else ""))
 618 )
 619
 620 ; Send the gen-defn message to OBJ, and sanitize the output if necessary.
 621
 622 (define (gen-defn obj)
 623   (logit 3 "Generating defn for "
 624          (cond ((method-present? obj 'get-name) (send obj 'get-name))
 625                ((elm-present? obj 'name) (elm-xget obj 'name))
 626                (else "unknown"))
 627          " ...\n")
 628   (cond ((and (method-present? obj 'gen-defn) (not (has-attr? obj 'META)))
 629          (gen-obj-sanitize obj (send obj 'gen-defn)))
 630         (else ""))
 631 )
 632 \f
 633 ; Attributes
 634
 635 ; Return the C/C++ type to use to hold a value for attribute ATTR.
 636
 637 (define (gen-attr-type attr)
 638   (if (string=? (string-downcase (gen-sym attr)) "isa")
 639       "CGEN_BITSET"
 640       (case (attr-kind attr)
 641         ((boolean) "int")
 642         ((bitset)  "unsigned int")
 643         ((integer) "int")
 644         ((enum)    (string-append "enum " (string-downcase (gen-sym attr)) "_attr"))
 645         ))
 646 )
 647
 648 ; Return C macros for accessing an object's attributes ATTRS.
 649 ; PREFIX is one of "cgen_ifld", "cgen_hw", "cgen_operand", "cgen_insn".
 650 ; ATTRS is an alist of attribute values.  The value is unimportant except that
 651 ; it is used to determine bool/non-bool.
 652 ; Non-bools need to be separated from bools as they're each recorded
 653 ; differently.  Non-bools are recorded in an int for each.  All bools are
 654 ; combined into one int to save space.
 655 ; ??? We assume there is at least one bool.
 656
 657 (define (-gen-attr-accessors prefix attrs)
 658   (string-append
 659    "/* " prefix " attribute accessor macros.  */\n"
 660    (string-map (lambda (attr)
 661                  (string-append
 662                   "#define CGEN_ATTR_"
 663                   (string-upcase prefix)
 664                   "_"
 665                   (string-upcase (gen-sym attr))
 666                   "_VALUE(attrs) "
 667                   (if (bool-attr? attr)
 668                       (string-append
 669                        "(((attrs)->bool & (1 << "
 670                        (string-upcase prefix)
 671                        "_"
 672                        (string-upcase (gen-sym attr))
 673                        ")) != 0)")
 674                       (string-append
 675                        "((attrs)->nonbool["
 676                        (string-upcase prefix)
 677                        "_"
 678                        (string-upcase (gen-sym attr))
 679                        "-"
 680                        (string-upcase prefix)
 681                        "_START_NBOOLS-1]."
 682                        (case (attr-kind attr)
 683                          ((bitset)
 684                           (if (string=? (string-downcase (gen-sym attr)) "isa")
 685                               ""
 686                               "non"))
 687                          (else "non"))
 688                        "bitset)"))
 689                   "\n"))
 690                attrs)
 691    "\n")
 692 )
 693 ; Return C code to declare an enum of attributes ATTRS.
 694 ; PREFIX is one of "cgen_ifld", "cgen_hw", "cgen_operand", "cgen_insn".
 695 ; ATTRS is an alist of attribute values.  The value is unimportant except that
 696 ; it is used to determine bool/non-bool.
 697 ; Non-bools need to be separated from bools as they're each recorded
 698 ; differently.  Non-bools are recorded in an int for each.  All bools are
 699 ; combined into one int to save space.
 700 ; ??? We assume there is at least one bool.
 701
 702 (define (gen-attr-enum-decl prefix attrs)
 703   (string-append
 704    (gen-enum-decl (string-append prefix "_attr")
 705                   (string-append prefix " attrs")
 706                   (string-append prefix "_")
 707                   (attr-list-enum-list attrs))
 708    "/* Number of non-boolean elements in " prefix "_attr.  */\n"
 709    "#define " (string-upcase prefix) "_NBOOL_ATTRS "
 710    "(" (string-upcase prefix) "_END_NBOOLS - "
 711    (string-upcase prefix) "_START_NBOOLS - 1)\n"
 712    "\n")
 713 )
 714
 715 ; Return name of symbol ATTR-NAME.
 716 ; PREFIX is the prefix arg to gen-attr-enum-decl.
 717
 718 (define (gen-attr-name prefix attr-name)
 719   (string-upcase (gen-c-symbol (string-append prefix "_"
 720                                               (symbol->string attr-name))))
 721 )
 722
 723 ; Normal gen-mask argument to gen-bool-attrs.
 724 ; Returns "(1<< PREFIX_NAME)" where PREFIX is from atlist-prefix and
 725 ; NAME is the name of the attribute.
 726 ; ??? This used to return PREFIX_NAME-CGEN_ATTR_BOOL_OFFSET.
 727 ; The tradeoff is simplicity vs perceived maximum number of boolean attributes
 728 ; needed.  In the end the maximum number needn't be fixed, and the simplicity
 729 ; of the current way is good.
 730
 731 (define (gen-attr-mask prefix name)
 732   (string-append "(1<<" (gen-attr-name prefix name) ")")
 733 )
 734
 735 ; Return C expression of bitmasks of boolean attributes in ATTRS.
 736 ; ATTRS is an <attr-list> object, it need not be pre-sorted.
 737 ; GEN-MASK is a procedure that returns the C code of the mask.
 738
 739 (define (gen-bool-attrs attrs gen-mask)
 740   (let loop ((result "0")
 741              (alist (attr-remove-meta-attrs-alist
 742                      (attr-nub (atlist-attrs attrs)))))
 743     (cond ((null? alist) result)
 744           ((and (boolean? (cdar alist)) (cdar alist))
 745            (loop (string-append result
 746                                 ; `|' is used here instead of `+' so we don't
 747                                 ; have to care about duplicates.
 748                                 "|" (gen-mask (atlist-prefix attrs)
 749                                               (caar alist)))
 750                  (cdr alist)))
 751           (else (loop result (cdr alist)))))
 752 )
 753
 754 ; Return the C definition of OBJ's attributes.
 755 ; TYPE is one of 'ifld, 'hw, 'operand, 'insn.
 756 ; [Other objects have attributes but these are the only ones we currently
 757 ; emit definitions for.]
 758 ; OBJ is any object that supports the 'get-atlist message.
 759 ; ALL-ATTRS is an ordered alist of all attributes.
 760 ; "ordered" means all the non-boolean attributes are at the front and
 761 ; duplicate entries have been removed.
 762 ; GEN-MASK is the gen-mask arg to gen-bool-attrs.
 763
 764 (define (gen-obj-attr-defn type obj all-attrs num-non-bools gen-mask)
 765   (let* ((attrs (obj-atlist obj))
 766          (non-bools (attr-non-bool-attrs (atlist-attrs attrs)))
 767          (all-non-bools (list-take num-non-bools all-attrs)))
 768   (string-append
 769    "{ "
 770    (gen-bool-attrs attrs gen-mask)
 771    ", {"
 772    ; For the boolean case, we can (currently) get away with only specifying
 773    ; the attributes that are used since they all fit in one int and the
 774    ; default is currently always #f (and won't be changed without good
 775    ; reason).  In the non-boolean case order is important since each value
 776    ; has a specific spot in an array, all of them must be specified.
 777    (if (null? all-non-bools)
 778        " 0"
 779        (string-drop1 ; drop the leading ","
 780         (string-map (lambda (attr)
 781                       (let ((val (or (assq-ref non-bools (obj:name attr))
 782                                      (attr-default attr))))
 783                         ; FIXME: Are we missing attr-prefix here?
 784                         (string-append ", "
 785                                        (send attr 'gen-value-for-defn val))))
 786                     all-non-bools)))
 787    " } }"
 788    ))
 789 )
 790
 791 ; Return the C definition of the terminating entry of an object's attributes.
 792 ; ALL-ATTRS is an ordered alist of all attributes.
 793 ; "ordered" means all the non-boolean attributes are at the front and
 794 ; duplicate entries have been removed.
 795
 796 (define (gen-obj-attr-end-defn all-attrs num-non-bools)
 797   (let ((all-non-bools (list-take num-non-bools all-attrs)))
 798     (string-append
 799      "{ 0, {"
 800      (if (null? all-non-bools)
 801          " { 0, 0 }"
 802          (string-drop1 ; drop the leading ","
 803           (string-map (lambda (attr)
 804                         (let ((val (attr-default attr)))
 805                                         ; FIXME: Are we missing attr-prefix here?
 806                           (string-append ", "
 807                                          (send attr 'gen-value-for-defn val))))
 808                       all-non-bools)))
 809      " } }"
 810      ))
 811 )
 812 ; Return a boolean indicating if ATLIST indicates a CTI insn.
 813
 814 (define (atlist-cti? atlist)
 815   (or (atlist-has-attr? atlist 'UNCOND-CTI)
 816       (atlist-has-attr? atlist 'COND-CTI))
 817 )
 818 \f
 819 ; Misc. gen-* procs
 820
 821 ; Return name of obj as a C symbol.
 822
 823 (define (gen-sym obj) (gen-c-symbol (obj:name obj)))
 824
 825 ; Return the name of the selected cpu family.
 826 ; An error is signalled if more than one has been selected.
 827
 828 (define (gen-cpu-name)
 829   ; FIXME: error checking
 830   (gen-sym (current-cpu))
 831 )
 832
 833 ; Return HAVE_CPU_<CPU>.
 834
 835 (define (gen-have-cpu cpu)
 836   (string-append "HAVE_CPU_"
 837                  (string-upcase (gen-sym cpu)))
 838 )
 839
 840 ; Return the bfd mach name for MACH.
 841
 842 (define (gen-mach-bfd-name mach)
 843   (string-append "bfd_mach_" (gen-c-symbol (mach-bfd-name mach)))
 844 )
 845
 846 ; Return definition of C macro to get the value of SYM.
 847
 848 (define (gen-get-macro sym index-args expr)
 849   (string-append
 850    "#define GET_" (string-upcase sym) "(" index-args ") " expr "\n")
 851 )
 852
 853 ; Return definition of C macro to set the value of SYM.
 854
 855 (define (gen-set-macro sym index-args lvalue)
 856   (string-append
 857    "#define SET_" (string-upcase sym)
 858    "(" index-args
 859    (if (equal? index-args "") "" ", ")
 860    "x) (" lvalue " = (x))\n")
 861 )
 862
 863 ; Return definition of C macro to set the value of SYM, version 2.
 864 ; EXPR is one or more C statements *without* proper \newline handling,
 865 ; we prepend \ to each line.
 866
 867 (define (gen-set-macro2 sym index-args newval-arg expr)
 868   (string-append
 869    "#define SET_" (string-upcase sym)
 870    "(" index-args
 871    (if (equal? index-args "") "" ", ")
 872    newval-arg ") \\\n"
 873    "do { \\\n"
 874    (backslash "\n" expr)
 875    ";} while (0)\n")
 876 )
 877 \f
 878 ; Misc. object utilities.
 879
 880 ; Sort a list of objects with get-name methods alphabetically.
 881
 882 (define (alpha-sort-obj-list l)
 883   (sort l
 884         (lambda (o1 o2)
 885           (symbol<? (obj:name o1) (obj:name o2))))
 886 )
 887 \f
 888 ; Called before loading the .cpu file to initialize.
 889
 890 (define (utils-init!)
 891   (reader-add-command! 'sanitize
 892                        "\
 893 Mark an entry as being sanitized.
 894 "
 895                        nil '(keyword entry-type . entry-names) sanitize)
 896
 897   *UNSPECIFIED*
 898 )
 899
 900 ; Return a pair of definitions for a C macro that concatenates its
 901 ; argument symbols.  The definitions are conditional on ANSI C
 902 ; semantics: one contains ANSI concat operators (##), and the other
 903 ; uses the empty-comment trick (/**/).  We must do this, rather than
 904 ; use CONCATn(...) as defined in include/symcat.h, in order to avoid
 905 ; spuriously expanding our macro's args.
 906
 907 (define (gen-define-with-symcat head . args)
 908   (string-append
 909    "\
 910 #if defined (__STDC__) || defined (ALMOST_STDC) || defined (HAVE_STRINGIZE)
 911 #define "
 912    head (string-map (lambda (elm) (string-append "##" elm)) args)
 913    "
 914 #else
 915 #define "
 916    head (string-map (lambda (elm) (string-append "/**/" elm)) args)
 917    "
 918 #endif
 919 "
 920    )
 921 )