← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/compiler/machines/spectrum/instr1.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
Import upstream version 7.7.0

Show diffs side-by-side

added added

removed removed

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