← 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/i386/insmac.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/i386/insmac.scm
 
1
#| -*-Scheme-*-
 
2
 
 
3
$Id: insmac.scm,v 1.17 2002/02/14 22:03:32 cph Exp $
 
4
 
 
5
Copyright (c) 1992, 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
;;;; Intel 386 Instruction Set Macros
 
24
 
 
25
(declare (usual-integrations))
 
26
 
 
27
(define-syntax define-trivial-instruction
 
28
  (sc-macro-transformer
 
29
   (lambda (form environment)
 
30
     (if (syntax-match? '(IDENTIFIER DATUM * DATUM) (cdr form))
 
31
         `(DEFINE-INSTRUCTION ,(cadr form)
 
32
            (()
 
33
             (BYTE (8 ,(close-syntax (caddr form) environment)))
 
34
             ,@(map (lambda (extra)
 
35
                      `(BYTE (8 ,(close-syntax extra environment))))
 
36
                    (cdddr form))))
 
37
         (ill-formed-syntax form)))))
 
38
 
 
39
;;;; Effective addressing
 
40
 
 
41
(define ea-database-name
 
42
  'EA-DATABASE)
 
43
 
 
44
(define-syntax define-ea-database
 
45
  (rsc-macro-transformer
 
46
   (lambda (form environment)
 
47
     `(,(close-syntax 'DEFINE environment)
 
48
       ,ea-database-name
 
49
       ,(compile-database (cdr form) environment
 
50
          (lambda (pattern actions)
 
51
            (let ((keyword (car pattern))
 
52
                  (categories (car actions))
 
53
                  (mode (cadr actions))
 
54
                  (register (caddr actions))
 
55
                  (tail (cdddr actions)))
 
56
              `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment)
 
57
                ',keyword
 
58
                ',categories
 
59
                ,(integer-syntaxer mode environment 'UNSIGNED 2)
 
60
                ,(integer-syntaxer register environment 'UNSIGNED 3)
 
61
                ,(if (null? tail)
 
62
                     `()
 
63
                     (process-fields tail #f environment))))))))))
 
64
 
 
65
;; This one is necessary to distinguish between r/mW mW, etc.
 
66
 
 
67
(define-syntax define-ea-transformer
 
68
  (sc-macro-transformer
 
69
   (lambda (form environment)
 
70
     environment
 
71
     (if (syntax-match? '(IDENTIFIER ? SYMBOL) (cdr form))
 
72
         `(DEFINE (,(cadr form) EXPRESSION)
 
73
            (LET ((MATCH-RESULT (PATTERN-LOOKUP ,ea-database-name EXPRESSION)))
 
74
              (AND MATCH-RESULT
 
75
                   ,(if (pair? (cddr form))
 
76
                        `(LET ((EA (MATCH-RESULT)))
 
77
                           (AND (MEMQ ',(caddr form) (EA/CATEGORIES EA))
 
78
                                EA))
 
79
                        `(MATCH-RESULT)))))
 
80
         (ill-formed-syntax form)))))
 
81
 
 
82
;; *** We can't really handle switching these right now. ***
 
83
 
 
84
(define-integrable *ADDRESS-SIZE* 32)
 
85
(define-integrable *OPERAND-SIZE* 32)
 
86
 
 
87
(define (parse-instruction opcode tail early? environment)
 
88
  (process-fields (cons opcode tail) early? environment))
 
89
 
 
90
(define (process-fields fields early? environment)
 
91
  (if (and (null? (cdr fields))
 
92
           (eq? (caar fields) 'VARIABLE-WIDTH))
 
93
      (expand-variable-width (car fields) early? environment)
 
94
      (call-with-values (lambda () (expand-fields fields early? environment))
 
95
        (lambda (code size)
 
96
          (if (not (zero? (remainder size 8)))
 
97
              (error "Bad syllable size:" size))
 
98
          code))))
 
99
 
 
100
(define (expand-variable-width field early? environment)
 
101
  (let ((binding (cadr field))
 
102
        (clauses (cddr field)))
 
103
    `(,(close-syntax 'LIST environment)
 
104
      ,(variable-width-expression-syntaxer
 
105
        (car binding)
 
106
        (cadr binding)
 
107
        environment
 
108
        (map (lambda (clause)
 
109
               (call-with-values
 
110
                   (lambda () (expand-fields (cdr clause) early? environment))
 
111
                 (lambda (code size)
 
112
                   (if (not (zero? (remainder size 8)))
 
113
                       (error "Bad clause size:" size))
 
114
                   `(,code ,size ,@(car clause)))))
 
115
             clauses)))))
 
116
 
 
117
(define (expand-fields fields early? environment)
 
118
  (if (pair? fields)
 
119
      (call-with-values
 
120
          (lambda () (expand-fields (cdr fields) early? environment))
 
121
       (lambda (tail tail-size)
 
122
         (case (caar fields)
 
123
           ;; For opcodes and fixed fields of the instruction
 
124
           ((BYTE)
 
125
            ;; (BYTE (8 #xff))
 
126
            ;; (BYTE (16 (+ foo #x23) SIGNED))
 
127
            (call-with-values
 
128
                (lambda ()
 
129
                  (collect-byte (cdar fields) tail environment))
 
130
              (lambda (code size)
 
131
                (values code (+ size tail-size)))))
 
132
           ((ModR/M)
 
133
            ;; (ModR/M 2 source)        = /2 r/m(source)
 
134
            ;; (ModR/M r target)        = /r r/m(target)
 
135
            (if early?
 
136
                (error "No early support for ModR/M -- Fix i386/insmac.scm"))
 
137
            (let ((field (car fields)))
 
138
              (let ((digit-or-reg (cadr field))
 
139
                    (r/m (caddr field)))
 
140
                (values `(,(close-syntax 'CONS-SYNTAX environment)
 
141
                          (,(close-syntax 'EA/REGISTER environment) ,r/m)
 
142
                          (,(close-syntax 'CONS-SYNTAX environment)
 
143
                           ,(integer-syntaxer digit-or-reg environment
 
144
                                              'UNSIGNED 3)
 
145
                           (,(close-syntax 'CONS-SYNTAX environment)
 
146
                            (,(close-syntax 'EA/MODE environment) ,r/m)
 
147
                            (,(close-syntax 'APPEND-SYNTAX! environment)
 
148
                             (,(close-syntax 'EA/EXTRA environment) ,r/m)
 
149
                             ,tail))))
 
150
                        (+ 8 tail-size)))))
 
151
           ;; For immediate operands whose size depends on the operand
 
152
           ;; size for the instruction (halfword vs. longword)
 
153
           ((IMMEDIATE)
 
154
            (values
 
155
             (let ((field (car fields)))
 
156
               (let ((value (cadr field))
 
157
                     (mode (if (pair? (cddr field)) (caddr field) 'OPERAND))
 
158
                     (domain
 
159
                      (if (and (pair? (cddr field)) (pair? (cdddr field)))
 
160
                          (cadddr field)
 
161
                          'SIGNED)))
 
162
                 `(,(close-syntax 'CONS-SYNTAX environment)
 
163
                   ,(integer-syntaxer
 
164
                     value
 
165
                     environment
 
166
                     domain
 
167
                     (case mode
 
168
                       ((OPERAND) *operand-size*)
 
169
                       ((ADDRESS) *address-size*)
 
170
                       (else (error "Unknown IMMEDIATE mode:" mode))))
 
171
                   ,tail)))
 
172
             tail-size))
 
173
           (else
 
174
            (error "Unknown field kind:" (caar fields))))))
 
175
      (values `'() 0)))
 
176
 
 
177
(define (collect-byte components tail environment)
 
178
  (let loop ((components components))
 
179
    (if (pair? components)
 
180
        (call-with-values (lambda () (loop (cdr components)))
 
181
          (lambda (byte-tail byte-size)
 
182
            (let ((size (caar components))
 
183
                  (expression (cadar components))
 
184
                  (type (if (pair? (cddar components))
 
185
                            (caddar components)
 
186
                            'UNSIGNED)))
 
187
              (values `(,(close-syntax 'CONS-SYNTAX environment)
 
188
                        ,(integer-syntaxer expression environment type size)
 
189
                        ,byte-tail)
 
190
                      (+ size byte-size)))))
 
191
        (values tail 0))))
 
 
b'\\ No newline at end of file'