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 / vax / dsyn.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  3.2 KB  |  98 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: dsyn.scm,v 1.8 1999/01/02 06:06:43 cph Exp $
  4. This file has no counterpart in the MC68020 compiler
  5.  
  6. Copyright (c) 1987, 1989, 1999 Massachusetts Institute of Technology
  7.  
  8. This program is free software; you can redistribute it and/or modify
  9. it under the terms of the GNU General Public License as published by
  10. the Free Software Foundation; either version 2 of the License, or (at
  11. your option) any later version.
  12.  
  13. This program is distributed in the hope that it will be useful, but
  14. WITHOUT ANY WARRANTY; without even the implied warranty of
  15. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16. General Public License for more details.
  17.  
  18. You should have received a copy of the GNU General Public License
  19. along with this program; if not, write to the Free Software
  20. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21. |#
  22.  
  23. ;;;; VAX Disassembler instruction definition syntax
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Instruction decoding
  28.  
  29. (define (initialize-package!)
  30.   (syntax-table-define disassembler-syntax-table
  31.       'DEFINE-INSTRUCTION
  32.     transform/define-instruction))
  33.  
  34. (define instructions-disassembled-specially
  35.   '(BYTE WORD LONG BUG B BR BSB))
  36.  
  37. (define disassembler-syntax-table
  38.   (make-syntax-table system-global-syntax-table))
  39.  
  40. (define transform/define-instruction
  41.   (macro (name . patterns)
  42.     (if (memq name instructions-disassembled-specially)
  43.     ''()
  44.     `(begin ,@(map (lambda (pattern)
  45.              (process-instruction-definition name pattern))
  46.                patterns)))))
  47.  
  48. (define (process-instruction-definition name pattern)
  49.   (let ((prefix (cons name (find-pattern-prefix (car pattern))))
  50.     (opcode-field (cadr pattern))
  51.     (operands (cddr pattern)))
  52.     (if (not (eq? (car opcode-field) 'BYTE))
  53.     (error "process-instruciton-definition: unhandled opcode kind"
  54.            opcode-field))
  55.     (let ((opcode (cadadr opcode-field)))
  56.       (case (caadr opcode-field)        ;size in bits
  57.     ((8)
  58.      `(define-standard-instruction ,opcode
  59.         ,(make-instruction-parser prefix operands)))
  60.     ((16)
  61.      (let ((low (remainder opcode 256))
  62.            (high (quotient opcode 256)))
  63.        (if (not (= low #xFD))
  64.            (error "process-instruction-definition: unhandled extension"
  65.               opcode))
  66.        `(define-extended-instruction ,high
  67.           ,(make-instruction-parser prefix operands))))
  68.     (else
  69.      (error "process-instruction-definition: bad opcode size"
  70.         (caadr opcode-field)))))))
  71.  
  72. (define (find-pattern-prefix pattern)    ; KLUDGE
  73.   (if (or (null? pattern)
  74.       (and (pair? (car pattern)) (eq? (caar pattern) '?)))
  75.       '()
  76.       (cons (car pattern) (find-pattern-prefix (cdr pattern)))))
  77.  
  78. (define (make-instruction-parser prefix operands)
  79.   `(lambda ()
  80.      (append ',prefix
  81.          ,(process-operands operands))))
  82.  
  83. ;; A let* is used below to force the order of evaluation.
  84.  
  85. (define (process-operands operands)
  86.   (if (null? operands)
  87.       ''()
  88.       `(let* ((this ,(let ((operand (car operands)))
  89.                (case (car operand)
  90.              ((OPERAND)
  91.               `(decode-operand ',(cadr operand)))
  92.              ((DISPLACEMENT)
  93.               `(decode-displacement ,(caadr operand)))
  94.              (else
  95.               (error "process-operand: Unknown operand kind"
  96.                  operand)))))
  97.           (rest ,(process-operands (cdr operands))))
  98.      (cons this rest))))