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 / spectrum / instr1.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  6.7 KB  |  278 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: instr1.scm,v 1.4 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987-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. ;;;; HP Spectrum instruction utilities
  23. ;;; Originally from Walt Hill, who did the hard part.
  24. ;;; package: (compiler lap-syntaxer)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define-transformer complx
  29.   (lambda (completer)
  30.     (vector (encode-S/SM completer)
  31.         (cc-val completer)
  32.         (m-val completer))))
  33.  
  34. (define-transformer compls
  35.   (lambda (completer)
  36.     (vector (encode-MB completer)
  37.         (cc-val completer)
  38.         (m-val completer))))
  39.  
  40. (define-transformer compledb
  41.   (lambda (completer)
  42.     (cons (encode-n completer)
  43.       (extract-deposit-condition completer))))
  44.  
  45. (define-transformer compled
  46.   (lambda (completer)
  47.     (extract-deposit-condition completer)))
  48.  
  49. (define-transformer complalb
  50.   (lambda (completer)
  51.     (cons (encode-n completer)
  52.       (arith-log-condition completer))))
  53.  
  54. (define-transformer complaltfb
  55.   (lambda (completer)
  56.     (list (encode-n completer)
  57.       (let ((val (arith-log-condition completer)))
  58.         (if (not (zero? (cadr val)))
  59.         (error "complaltfb: Bad completer" completer)
  60.         (car val))))))
  61.  
  62. (define-transformer complal
  63.   (lambda (completer)
  64.     (arith-log-condition completer)))
  65.  
  66. (define-transformer complaltf
  67.   (lambda (completer)
  68.     (let ((val (arith-log-condition completer)))
  69.       (if (not (zero? (cadr val)))
  70.       (error "complaltf: Bad completer" completer)
  71.       val))))
  72.  
  73. (define-transformer fpformat
  74.   (lambda (completer)
  75.     (encode-fpformat completer)))
  76.  
  77. (define-transformer fpcond
  78.   (lambda (completer)
  79.     (encode-fpcond completer)))
  80.  
  81. (define-transformer sr3
  82.   (lambda (value)
  83.     (let ((place (assq value '((0 . 0) (1 . 2) (2 . 4) (3 . 6)
  84.                    (4 . 1) (5 . 3) (6 . 5) (7 . 7)))))
  85.       (if place
  86.       (cdr place)
  87.       (error "sr3: Invalid space register descriptor" value)))))
  88.  
  89. ;;;; Utilities
  90.  
  91. (define-integrable (branch-extend-pco disp nullify?)
  92.   (if (and (= nullify? 1)
  93.        (negative? disp))
  94.       4
  95.       0))
  96.  
  97. (define-integrable (branch-extend-nullify disp nullify?)
  98.   (if (and (= nullify? 1)
  99.       (not (negative? disp)))
  100.       1
  101.       0))
  102.  
  103. (define-integrable (branch-extend-disp disp)
  104.   (- disp 4))
  105.  
  106. (define-integrable (branch-extend-edcc cc)
  107.   (remainder (+ cc 4) 8))
  108.  
  109. (define-integrable (encode-N completers)
  110.   (if (memq 'N completers)
  111.       1
  112.       0))
  113.  
  114. (define-integrable (encode-S/SM completers)
  115.   (if (or (memq 'S completers) (memq 'SM completers))
  116.       1
  117.       0))
  118.  
  119. (define-integrable (encode-MB completers)
  120.   (if (memq 'MB completers)
  121.       1
  122.       0))
  123.  
  124. (define-integrable (m-val compl-list)
  125.   (if (or (memq 'M compl-list)
  126.       (memq 'SM compl-list)
  127.       (memq 'MA compl-list)
  128.       (memq 'MB compl-list))
  129.       1
  130.       0))
  131.  
  132. (define-integrable (cc-val compl-list)
  133.   (cond ((memq 'P compl-list) 3)
  134.     ((memq 'Q compl-list) 2)
  135.     ((memq 'C compl-list) 1)
  136.     (else 0)))
  137.  
  138. (define (extract-deposit-condition compl)
  139.   (cond ((or (null? compl) (memq 'NV compl)) 0)
  140.     ((or (memq 'EQ compl) (memq '= compl)) 1)
  141.     ((or (memq 'LT compl) (memq '< compl)) 2)
  142.     ((memq 'OD compl) 3)
  143.     ((memq 'TR compl) 4)
  144.     ((or (memq 'LTGT compl) (memq '<> compl)) 5)
  145.     ((or (memq 'GTEQ compl) (memq '>= compl)) 6)
  146.     ((memq 'EV compl) 7)
  147.     (else
  148.      ;; This should really error out, but it's hard to
  149.      ;; arrange given that the compl includes other
  150.      ;; fields.
  151.      0)))
  152.  
  153. (define-integrable (encode-fpformat compl)
  154.   (case compl
  155.     ((DBL) 1)
  156.     ((SGL) 0)
  157.     ((QUAD) 3)
  158.     (else
  159.      (error "Missing Floating Point Format" compl))))
  160.  
  161. (define-integrable (encode-fpcond fpcond)
  162.   (let ((place (assq fpcond float-condition-table)))
  163.     (if place
  164.     (cadr place)
  165.     (error "encode-fpcond: Unknown condition" fpcond))))
  166.  
  167. (define float-condition-table
  168.   '((false?    0)
  169.     (false    1)
  170.     (?        2)
  171.     (!<=>    3)
  172.     (=        4)
  173.     (=T        5)
  174.     (?=        6)
  175.     (!<>    7)
  176.     (!?>=    8)
  177.     (<        9)
  178.     (?<        10)
  179.     (!>=    11)
  180.     (!?>    12)
  181.     (<=        13)
  182.     (?<=    14)
  183.     (!>        15)
  184.     (!?<=    16)
  185.     (>        17)
  186.     (?>        18)
  187.     (!<=    19)
  188.     (!?<    20)
  189.     (>=        21)
  190.     (?>=    22)
  191.     (!<        23)
  192.     (!?=    24)
  193.     (<>        25)
  194.     (!=        26)
  195.     (!=T    27)
  196.     (!?        28)
  197.     (<=>    29)
  198.     (true?    30)
  199.     (true    31)))
  200.     
  201. (define (arith-log-condition compl-list)
  202.   ;; Returns (c f)
  203.   (let loop ((compl-list compl-list))
  204.     (if (null? compl-list)
  205.     '(0 0)
  206.     (let ((val (assq (car compl-list) arith-log-condition-table)))
  207.       (if val
  208.           (cadr val)
  209.           (loop (cdr compl-list)))))))
  210.  
  211. (define arith-log-condition-table
  212.   '((NV      (0 0))
  213.     (EQ      (1 0))
  214.     (=       (1 0))
  215.     (LT      (2 0))
  216.     (<       (2 0))
  217.     (SBZ     (2 0))
  218.     (LTEQ    (3 0))
  219.     (<=      (3 0))
  220.     (SHZ     (3 0))
  221.     (LTLT    (4 0))
  222.     (<<      (4 0))
  223.     (NUV     (4 0))
  224.     (SDC     (4 0))
  225.     (LTLTEQ  (5 0))
  226.     (<<=     (5 0))
  227.     (ZNV     (5 0))
  228.     (SV      (6 0))
  229.     (SBC     (6 0))
  230.     (OD      (7 0))
  231.     (SHC     (7 0))
  232.     (TR      (0 1))
  233.     (LTGT    (1 1))
  234.     (<>      (1 1))
  235.     (GTEQ    (2 1))
  236.     (>=      (2 1))
  237.     (NBZ     (2 1))
  238.     (GT      (3 1))
  239.     (>       (3 1))
  240.     (NHZ     (3 1))
  241.     (GTGTEQ  (4 1))
  242.     (>>=     (4 1))
  243.     (UV      (4 1))
  244.     (NDC     (4 1))
  245.     (GTGT    (5 1))
  246.     (>>      (5 1))
  247.     (VNZ     (5 1))
  248.     (NSV     (6 1))
  249.     (NBC     (6 1))
  250.     (EV      (7 1))
  251.     (NHC     (7 1))))
  252.  
  253. (define-integrable (tf-adjust opcode condition)
  254.   (+ opcode (* 2 (cadr condition))))
  255.  
  256. (define (tf-adjust-inverted opcode condition)
  257.   (+ opcode (* 2 (- 1 (cadr condition)))))
  258.  
  259. (define (make-operator name handler)
  260.   (lambda (value)
  261.     (if (exact-integer? value)
  262.     (handler value)
  263.     `(,name ,value))))    
  264.  
  265. (let-syntax ((define-operator
  266.            (macro (name handler)
  267.          `(define ,name
  268.             (make-operator ',name ,handler)))))
  269.  
  270. (define-operator LEFT
  271.   (lambda (number)
  272.     (bit-string->signed-integer
  273.      (bit-substring (signed-integer->bit-string 32 number) 11 32))))
  274.  
  275. (define-operator RIGHT
  276.   (lambda (number)
  277.     (bit-string->unsigned-integer
  278.      (bit-substring (signed-integer->bit-string 32 number) 0 11)))))