diff options
Diffstat (limited to 'module/language/sassy/operands.scm')
| -rw-r--r-- | module/language/sassy/operands.scm | 244 |
1 files changed, 244 insertions, 0 deletions
diff --git a/module/language/sassy/operands.scm b/module/language/sassy/operands.scm new file mode 100644 index 000000000..0c5ff844c --- /dev/null +++ b/module/language/sassy/operands.scm @@ -0,0 +1,244 @@ +; operands.scm - Sassy's operand predicates +; Copyright (C) 2005 Jonathan Kraut + +; This library is free software; you can redistribute it and/or +; modify it under the terms of the GNU Lesser General Public +; License as published by the Free Software Foundation; either +; version 2.1 of the License, or (at your option) any later version. + +; This library is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; Lesser General Public License for more details. + +; You should have received a copy of the GNU Lesser General Public +; License along with this library; if not, write to the Free Software +; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +; Contact: +; Jonathan Kraut +; 4130 43 ST #C2 +; Sunnyside, NY 11104 +; jak76@columbia.edu + +; see file COPYING in the top of Sassy's distribution directory + + +; module operands +; import numbers srfi-69 +; import-syntax meta-lambda +; export all + + +; register type operands +(define r8 #f) +(define r16 #f) +(define r32 #f) +(define mm #f) +(define st #f) +(define xmm #f) +(define creg #f) +(define dreg #f) +(define sreg #f) +(define (r32-not-esp x) (and (not (eq? x 'esp)) (r32 x))) +(define (sreg-not-cs x) (and (not (eq? x 'cs)) (sreg x))) + +(define symbol #f) +(let + ((the-registers + (alist->hash-table + '((eax . (32 . 0)) (ecx . (32 . 1)) (edx . (32 . 2)) (ebx . (32 . 3)) + (esp . (32 . 4)) (ebp . (32 . 5)) (esi . (32 . 6)) (edi . (32 . 7)) + (ax . (16 . 0)) (cx . (16 . 1)) (dx . (16 . 2)) (bx . (16 . 3)) + (sp . (16 . 4)) (bp . (16 . 5)) (si . (16 . 6)) (di . (16 . 7)) + (al . (8 . 0)) (cl . (8 . 1)) (dl . (8 . 2)) (bl . (8 . 3)) + (ah . (8 . 4)) (ch . (8 . 5)) (dh . (8 . 6)) (bh . (8 . 7)) + (st0 . (80 . 0)) (st1 . (80 . 1)) (st2 . (80 . 2)) (st3 . (80 . 3)) + (st4 . (80 . 4)) (st5 . (80 . 5)) (st6 . (80 . 6)) (st7 . (80 . 7)) + (mm0 . (64 . 0)) (mm1 . (64 . 1)) (mm2 . (64 . 2)) (mm3 . (64 . 3)) + (mm4 . (64 . 4)) (mm5 . (64 . 5)) (mm6 . (64 . 6)) (mm7 . (64 . 7)) + (xmm0 . (128 . 0)) (xmm1 . (128 . 1)) (xmm2 . (128 . 2)) + (xmm3 . (128 . 3)) (xmm4 . (128 . 4)) (xmm5 . (128 . 5)) + (xmm6 . (128 . 6)) (xmm7 . (128 . 7)) + (es . (1 . 0)) (cs . (1 . 1)) (ss . (1 . 2)) + (ds . (1 . 3)) (fs . (1 . 4)) (gs . (1 . 5)) + (cr0 . (2 . 0)) (cr2 . (2 . 2)) (cr3 . (2 . 3)) (cr4 . (2 . 4)) + (dr0 . (3 . 0)) (dr1 . (3 . 1)) (dr2 . (3 . 2)) + (dr3 . (3 . 3)) (dr6 . (3 . 6)) (dr7 . (3 . 7)) + )))) ;sreg type-code = 1 creg type-code = 2 dreg type-code = 3 + (let ((reg-x (lambda (reg-type-code) + (memoize + (lambda (x) + (cond ((hash-table-ref the-registers x (lambda () #f)) => + (lambda (found) + (and (= reg-type-code (car found)) (cdr found)))) + (else #f))))))) + (set! r8 (reg-x 8)) + (set! r16 (reg-x 16)) + (set! r32 (reg-x 32)) + (set! mm (reg-x 64)) + (set! st (reg-x 80)) + (set! xmm (reg-x 128)) + (set! creg (reg-x 2)) + (set! dreg (reg-x 3)) + (set! sreg (reg-x 1)) + (set! symbol (memoize + (lambda (x) + (or (and (symbol? x) + (not (hash-table-ref the-registers + x (lambda () #f))) + x) + (custom-reloc x))))))) + +; For the remainder of the following, every operand is either an e_ u_ +; or general. The u-types are for unexplicit operand sizes. The +; e-types are for the cases where the operand size if explicit, and +; the general is either of those. + +; mem type operands - the actual parsing happens in proc-mem in operands +(define um8 + (memoize + (let ((segger (lambda (x) (and (memq x '(cs ss ds es fs gs)) x))) + (mem (meta-lambda (and '& __)))) + (meta-lambda + (or ,@mem + (and segger mem)))))) +(define um16 um8) +(define um32 um8) +(define um64 um8) +(define um80 um8) +(define um128 um8) + +(define em8 (memoize (meta-lambda (and 'byte um8)))) +(define em16 (memoize (meta-lambda (and 'word um16)))) +(define em32 (memoize (meta-lambda (and 'dword um32)))) +(define em64 (memoize (meta-lambda (and 'qword um64)))) +(define em80 (memoize (meta-lambda (and 'tword um80)))) +(define em128 (memoize (meta-lambda (and 'dqword um128)))) + +(define (m8 x) (or (um8 x) (em8 x))) +(define (m16 x) (or (um16 x) (em16 x))) +(define (m32 x) (or (um32 x) (em32 x))) +(define (m64 x) (or (um64 x) (em64 x))) +(define (m80 x) (or (um80 x) (em80 x))) +(define (m128 x) (or (um128 x) (em128 x))) + +(define (mem-any x) + (or (m32 x) (m16 x) (m8 x) (m64 x) (m80 x) (m128 x))) + + +; NOTE: This needs fixing. The current bit-size should be checked to +; make sure that "target" and "value", if specified, fit within the +; current bit size. +(define custom-reloc + (meta-lambda + (and 'reloc + (or (and 'rel + (or symbol? u-dword) + (or (lambda (target) (list 'reloc 'rel target 0)) + (else (lambda x (error "sassy: bad rel reloc" x))))) + (and symbol? + (or (lambda (type) (list 'reloc type #f 0)) + (and (or symbol? u-dword) + (or (lambda (type target) (list 'reloc type target 0)) + (and s-dword + (lambda (type target value) + (list 'reloc type target value))))))))))) + +; rel type operands are used by branches + +(define urel8 (memoize (meta-lambda (or ,@u-byte ,@symbol)))) +(define urel16 (memoize (meta-lambda (or ,@u-word ,@symbol)))) +(define urel32 (memoize (meta-lambda (or ,@u-dword ,@symbol)))) + +(define erel8 (memoize (meta-lambda (and 'byte urel8)))) +(define erel16 (memoize (meta-lambda (and 'word urel16)))) +(define erel32 (memoize (meta-lambda (and 'dword urel32)))) + +(define (rel8 x) (or (urel8 x) (erel8 x))) +(define (rel16 x) (or (urel16 x) (erel16 x))) +(define (rel32 x) (or (urel32 x) (erel32 x))) + +; mi type operand is used by mov instruction only with eax +(define umi8 #f) +(define umi16 #f) +(define umi32 #f) + +(define emi8 (memoize (meta-lambda (and 'byte umi8)))) +(define emi16 (memoize (meta-lambda (and 'word umi16)))) +(define emi32 (memoize (meta-lambda (and 'dword umi32)))) + +(define (mi8 x) (or (umi8 x) (emi8 x))) +(define (mi16 x) (or (umi16 x) (emi16 x))) +(define (mi32 x) (or (umi32 x) (emi32 x))) + +(let ((mi (lambda (x) + (let ((asym #f) + (acc 0)) + (let ((a-rest + (meta-lambda + (or (and ,@symbol + (lambda (x) (and (not asym) (set! asym x)))) + (and ,@integer? + (lambda (x) (set! acc (+ x acc)))))))) + (let ((go (meta-lambda + (and '& (+ a-rest) + (begin + (cond ((pair? asym) + (list 'reloc (car asym) (cadr asym) + (+ acc (caddr asym)))) + ((symbol? asym) + (list 'reloc 'abs asym acc)) + ((not asym) acc))))))) +; (list 'reloc 'abs acc 0)))))))) + (go x))))))) + (set! umi8 mi) + (set! umi16 mi) + (set! umi32 mi)) + +; immediate type operands +; unexplicit +(define ui8 #f) +(define ui16 #f) +(define ui32 #f) + +; explicit eg (dword N) +(define ei8 (memoize (meta-lambda (and 'byte ui8)))) +(define ei16 (memoize (meta-lambda (and 'word ui16)))) +(define ei32 (memoize (meta-lambda (and 'dword ui32)))) + +; any +(define (i8 x) (or (ui8 x) (ei8 x))) +(define (i16 x) (or (ui16 x) (ei16 x))) +(define (i32 x) (or (ui32 x) (ei32 x))) + +(let ((string-able + (lambda (z) + (lambda (x) + (and (string? x) + (<= (string-length x) z) + (let ((tmp (string-append x (make-string (- z (string-length x)) + (integer->char 0))))) + (do ((i (- z 1) (- i 1)) + (r 0 (+ (ash r 8) (char->integer (string-ref tmp i))))) + ((< i 0) r)))))))) + (let ((str1 (string-able 1)) + (str2 (string-able 2)) + (str4 (string-able 4)) + (u/s-byte u/s-byte) + (u/s-word u/s-word) + (u/s-dword u/s-dword)) + (let ((imm16/32 + (lambda (num-pred str-pred) + (meta-lambda + (or ,@num-pred + ,@symbol + ,@str-pred + (and ,@char? (lambda (x) (char->integer x)))))))) + (set! ui8 (memoize + (meta-lambda + (or ,@u/s-byte + ,@str1 + (and ,@char? (lambda (x) (char->integer x))))))) + (set! ui16 (memoize (imm16/32 u/s-word str2))) + (set! ui32 (memoize (imm16/32 u/s-dword str4)))))) |