home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / machines / sparc / insmac.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  4.1 KB  |  136 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: insmac.scm,v 1.2 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; SPARC Instruction Set Macros
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; Definition macros
  27.  
  28. (syntax-table-define assembler-syntax-table 'DEFINE-SYMBOL-TRANSFORMER
  29.   (macro (name . alist)
  30.     `(BEGIN
  31.        (DECLARE (INTEGRATE-OPERATOR ,name))
  32.        (DEFINE (,name SYMBOL)
  33.      (DECLARE (INTEGRATE SYMBOL))
  34.      (LET ((PLACE (ASSQ SYMBOL ',alist)))
  35.        (IF (NULL? PLACE)
  36.            #F
  37.            (CDR PLACE)))))))
  38.  
  39. (syntax-table-define assembler-syntax-table 'DEFINE-TRANSFORMER
  40.   (macro (name value)
  41.     `(DEFINE ,name ,value)))
  42.  
  43. ;;;; Fixed width instruction parsing
  44.  
  45. (define (parse-instruction first-word tail early?)
  46.   (if (not (null? tail))
  47.       (error "parse-instruction: Unknown format" (cons first-word tail)))
  48.   (let loop ((first-word first-word))
  49.     (case (car first-word)
  50.       ((LONG)
  51.        (process-fields (cdr first-word) early?))
  52.       ((VARIABLE-WIDTH)
  53.        (process-variable-width first-word early?))
  54.       ((IF)
  55.        `(IF ,(cadr first-word)
  56.         ,(loop (caddr first-word))
  57.         ,(loop (cadddr first-word))))
  58.       (else
  59.        (error "parse-instruction: Unknown format" first-word)))))
  60.  
  61. (define (process-variable-width descriptor early?)
  62.   (let ((binding (cadr descriptor))
  63.     (clauses (cddr descriptor)))
  64.     `(LIST
  65.       ,(variable-width-expression-syntaxer
  66.     (car binding)            ; name
  67.     (cadr binding)            ; expression
  68.     (map (lambda (clause)
  69.            (expand-fields
  70.         (cdadr clause)
  71.         early?
  72.         (lambda (code size)
  73.           (if (not (zero? (remainder size 32)))
  74.               (error "process-variable-width: bad clause size" size))
  75.           `((LIST ,(optimize-group-syntax code early?))
  76.             ,size
  77.             ,@(car clause)))))
  78.          clauses)))))
  79.  
  80. (define (process-fields fields early?)
  81.   (expand-fields fields
  82.          early?
  83.          (lambda (code size)
  84.            (if (not (zero? (remainder size 32)))
  85.                (error "process-fields: bad syllable size" size))
  86.            `(LIST ,(optimize-group-syntax code early?)))))
  87.  
  88. (define (expand-fields fields early? receiver)
  89.   (define (expand first-word word-size fields receiver)
  90.     (if (null? fields)
  91.     (receiver '() 0)
  92.     (expand-field
  93.      (car fields) early?
  94.      (lambda (car-field car-size)
  95.        (if (and (eq? endianness 'LITTLE)
  96.             (= 32 (+ word-size car-size)))
  97.            (expand '() 0 (cdr fields)
  98.                (lambda (tail tail-size)
  99.              (receiver
  100.               (append (cons car-field first-word) tail)
  101.               (+ car-size tail-size))))
  102.            (expand (cons car-field first-word)
  103.                (+ car-size word-size)
  104.                (cdr fields)
  105.                (lambda (tail tail-size)
  106.              (receiver
  107.               (if (or (zero? car-size)
  108.                   (not (eq? endianness 'LITTLE)))
  109.                   (cons car-field tail)
  110.                   tail)
  111.               (+ car-size tail-size)))))))))
  112.   (expand '() 0 fields receiver))
  113.  
  114. (define (expand-field field early? receiver)
  115.   early?                ; ignored for now
  116.   (let ((size (car field))
  117.     (expression (cadr field)))
  118.  
  119.     (define (default type)
  120.       (receiver (integer-syntaxer expression type size)
  121.         size))
  122.  
  123.     (if (null? (cddr field))
  124.     (default 'UNSIGNED)
  125.     (case (caddr field)
  126.       ((PC-REL)
  127.        (receiver
  128.         (integer-syntaxer ``(- ,,expression (+ *PC* 4))
  129.                   (cadddr field)
  130.                   size)
  131.         size))
  132.       ((BLOCK-OFFSET)
  133.        (receiver (list 'list ''BLOCK-OFFSET expression)
  134.              size))
  135.       (else
  136.        (default (caddr field)))))))