From 3f361264651d37ee99b4c00cbb0d03a5821cc183 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 14 Feb 2002 22:03:32 +0000 Subject: [PATCH] Change most instruction-set macros to use reverse syntactic closure style, and propagate changes down through the maze of supporting procedures. --- v7/src/compiler/back/asmmac.scm | 81 ++++--- v7/src/compiler/back/syntax.scm | 60 +++--- v7/src/compiler/machines/alpha/insmac.scm | 142 ++++++------ v7/src/compiler/machines/bobcat/insmac.scm | 76 ++++--- v7/src/compiler/machines/i386/insmac.scm | 13 +- v7/src/compiler/machines/mips/insmac.scm | 167 +++++++------- v7/src/compiler/machines/sparc/insmac.scm | 167 +++++++------- v7/src/compiler/machines/spectrum/insmac.scm | 168 ++++++++------- v7/src/compiler/machines/vax/insmac.scm | 216 ++++++++++--------- 9 files changed, 578 insertions(+), 512 deletions(-) diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm index 59d5e5eb3..e2096626e 100644 --- a/v7/src/compiler/back/asmmac.scm +++ b/v7/src/compiler/back/asmmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: asmmac.scm,v 1.16 2002/02/14 15:56:53 cph Exp $ +$Id: asmmac.scm,v 1.17 2002/02/14 22:03:32 cph Exp $ Copyright (c) 1988, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology @@ -52,48 +52,47 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA environment))))) cases))) -(define optimize-group-syntax - (let () - (define (find-constant components) - (cond ((null? components) - '()) - ((car-constant? components) - (compact (car-constant-value components) - (cdr components))) - (else - (cons (car components) - (find-constant (cdr components)))))) +(define (optimize-group-syntax components early? environment) + (define (find-constant components) + (cond ((null? components) + '()) + ((car-constant? components) + (compact (car-constant-value components) + (cdr components))) + (else + (cons (car components) + (find-constant (cdr components)))))) - (define (compact bit-string components) - (cond ((null? components) - (cons (make-constant bit-string) '())) - ((car-constant? components) - (compact (instruction-append bit-string - (car-constant-value components)) - (cdr components))) - (else - (cons (make-constant bit-string) - (cons (car components) - (find-constant (cdr components))))))) + (define (compact bit-string components) + (cond ((null? components) + (cons (make-constant bit-string) '())) + ((car-constant? components) + (compact (instruction-append bit-string + (car-constant-value components)) + (cdr components))) + (else + (cons (make-constant bit-string) + (cons (car components) + (find-constant (cdr components))))))) - (define-integrable (car-constant? expression) - (and (eq? (caar expression) 'QUOTE) - (bit-string? (cadar expression)))) + (define (car-constant? components) + (and (identifier=? environment (caar components) + system-global-environment 'QUOTE) + (bit-string? (cadar components)))) - (define-integrable (car-constant-value constant) - (cadar constant)) + (define-integrable (car-constant-value constant) + (cadar constant)) - (define-integrable (make-constant bit-string) - `',bit-string) + (define-integrable (make-constant bit-string) + `',bit-string) - (lambda (components early?) - (let ((components (find-constant components))) - (cond ((null? components) - (error "OPTIMIZE-GROUP-SYNTAX: No components in group!")) - ((null? (cdr components)) - (car components)) - (else - `(,(if early? - 'OPTIMIZE-GROUP-EARLY - 'OPTIMIZE-GROUP) - ,@components))))))) \ No newline at end of file + (let ((components (find-constant components))) + (if (not (pair? components)) + (error "No components in group!")) + (if (pair? (cdr components)) + `(,(close-syntax (if early? + 'OPTIMIZE-GROUP-EARLY + 'OPTIMIZE-GROUP) + environment) + ,@components) + (car components)))) \ No newline at end of file diff --git a/v7/src/compiler/back/syntax.scm b/v7/src/compiler/back/syntax.scm index 0cb32c04d..9f8a73a8d 100644 --- a/v7/src/compiler/back/syntax.scm +++ b/v7/src/compiler/back/syntax.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: syntax.scm,v 1.28 2001/12/20 18:47:01 cph Exp $ +$Id: syntax.scm,v 1.29 2002/02/14 22:03:32 cph Exp $ -Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -80,11 +80,11 @@ USA. (define instructions '()) -(define (integer-syntaxer expression coercion-type size) +(define (integer-syntaxer expression environment coercion-type size) (let ((name (make-coercion-name coercion-type size))) (if (exact-integer? expression) `',((lookup-coercion name) expression) - `(SYNTAX-EVALUATION ,expression ,name)))) + `(,(close-syntax 'SYNTAX-EVALUATION environment) ,expression ,name)))) (define (syntax-evaluation expression coercion) (if (exact-integer? expression) @@ -132,33 +132,25 @@ USA. ;;;; Variable width expression processing -(define (choose-clause value clauses) - (if (null? clauses) - (error "CHOOSE-CLAUSE: value out of range" value)) - (if (let ((low (caddr (car clauses))) - (high (cadddr (car clauses)))) - (and (or (null? low) - (<= low value)) - (or (null? high) - (<= value high)))) - (car clauses) - (choose-clause value (cdr clauses)))) - -(define (variable-width-expression-syntaxer name expression clauses) +(define (variable-width-expression-syntaxer name expression environment + clauses) (if (exact-integer? expression) (let ((chosen (choose-clause expression clauses))) - `(LET ((,name ,expression)) - (DECLARE (INTEGRATE ,name)) - ,name ;ignore if not referenced - (CAR ,(car chosen)))) - `(SYNTAX-VARIABLE-WIDTH-EXPRESSION + `(,(close-syntax 'LET environment) + ((,name ,expression)) + (,(close-syntax 'DECLARE environment) (INTEGRATE ,name)) + ,name ;ignore if not referenced + (,(close-syntax 'CAR environment) ,(car chosen)))) + `(,(close-syntax 'SYNTAX-VARIABLE-WIDTH-EXPRESSION environment) ,expression - (LIST - ,@(map (LAMBDA (clause) - `(CONS (LAMBDA (,name) - ,name ;ignore if not referenced - ,(car clause)) - ',(cdr clause))) + (,(close-syntax 'LIST environment) + ,@(map (lambda (clause) + `(,(close-syntax 'CONS environment) + (,(close-syntax 'LAMBDA environment) + (,name) + ,name ;ignore if not referenced + ,(car clause)) + ',(cdr clause))) clauses))))) (define (syntax-variable-width-expression expression clauses) @@ -168,6 +160,18 @@ USA. `(VARIABLE-WIDTH-EXPRESSION ,expression ,@clauses))) + +(define (choose-clause value clauses) + (if (not (pair? clauses)) + (error "Value out of range:" value)) + (if (let ((low (caddr (car clauses))) + (high (cadddr (car clauses)))) + (and (or (null? low) + (<= low value)) + (or (null? high) + (<= value high)))) + (car clauses) + (choose-clause value (cdr clauses)))) ;;;; Coercion Machinery diff --git a/v7/src/compiler/machines/alpha/insmac.scm b/v7/src/compiler/machines/alpha/insmac.scm index 0c82455e7..2664d3604 100644 --- a/v7/src/compiler/machines/alpha/insmac.scm +++ b/v7/src/compiler/machines/alpha/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.5 2002/02/13 05:56:24 cph Exp $ +$Id: insmac.scm,v 1.6 2002/02/14 22:03:32 cph Exp $ Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology @@ -38,99 +38,107 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA #F)))))) (define-syntax define-transformer - (sc-macro-transformer + (rsc-macro-transformer (lambda (form environment) - `(DEFINE ,(cadr form) ,(close-syntax (caddr form) environment))))) + `(,(close-syntax 'DEFINE environment) ,@(cdr form))))) ;;;; Fixed width instruction parsing -(define (parse-instruction first-word tail early?) +(define (parse-instruction first-word tail early? environment) (if (not (null? tail)) - (error "parse-instruction: Unknown format" (cons first-word tail))) + (error "Unknown format:" (cons first-word tail))) (let loop ((first-word first-word)) (case (car first-word) ((LONG) - (process-fields (cdr first-word) early?)) + (process-fields (cdr first-word) early? environment)) ((VARIABLE-WIDTH) - (process-variable-width first-word early?)) + (process-variable-width first-word early? environment)) ((IF) - `(IF ,(cadr first-word) - ,(loop (caddr first-word)) - ,(loop (cadddr first-word)))) + `(,(close-syntax 'IF environment) + ,(cadr first-word) + ,(loop (caddr first-word)) + ,(loop (cadddr first-word)))) (else - (error "parse-instruction: Unknown format" first-word))))) + (error "Unknown format:" first-word))))) -(define (process-variable-width descriptor early?) +(define (process-variable-width descriptor early? environment) (let ((binding (cadr descriptor)) (clauses (cddr descriptor))) - `(LIST + `(,(close-syntax 'LIST environment) ,(variable-width-expression-syntaxer (car binding) ; name (cadr binding) ; expression + environment (map (lambda (clause) - (expand-fields - (cdadr clause) - early? - (lambda (code size) - (if (not (zero? (remainder size 32))) - (error "process-variable-width: bad clause size" size)) - `((LIST ,(optimize-group-syntax code early?)) - ,size - ,@(car clause))))) - clauses))))) - -(define (process-fields fields early?) - (expand-fields fields - early? + (call-with-values + (lambda () + (expand-fields (cdadr clause) early? environment)) (lambda (code size) (if (not (zero? (remainder size 32))) - (error "process-fields: bad syllable size" size)) - `(LIST ,(optimize-group-syntax code early?))))) - -(define (expand-fields fields early? receiver) - (define (expand first-word word-size fields receiver) - (if (null? fields) - (receiver '() 0) - (expand-field - (car fields) early? - (lambda (car-field car-size) - (if (= 32 (+ word-size car-size)) - (expand '() 0 (cdr fields) - (lambda (tail tail-size) - (receiver - (append (cons car-field first-word) tail) - (+ car-size tail-size)))) - (expand (cons car-field first-word) - (+ car-size word-size) - (cdr fields) - (lambda (tail tail-size) - (receiver - (if (zero? car-size) - (cons car-field tail) - tail) - (+ car-size tail-size))))))))) - (expand '() 0 fields receiver)) - -(define (expand-field field early? receiver) + (error "Bad clause size:" size)) + `((,(close-syntax 'LIST environment) + ,(optimize-group-syntax code early? environment)) + ,size + ,@(car clause))))) + clauses))))) + +(define (process-fields fields early? environment) + (call-with-values (lambda () (expand-fields fields early? environment)) + (lambda (code size) + (if (not (zero? (remainder size 32))) + (error "process-fields: bad syllable size" size)) + `(,(close-syntax 'LIST environment) + ,(optimize-group-syntax code early? environment))))) + +(define (expand-fields fields early? environment) + (let expand ((first-word '()) (word-size 0) (fields fields)) + (if (pair? fields) + (call-with-values + (lambda () (expand-field (car fields) early? environment)) + (lambda (car-field car-size) + (if (= 32 (+ word-size car-size)) + (call-with-values (lambda () (expand '() 0 (cdr fields))) + (lambda (tail tail-size) + (values (append (cons car-field first-word) tail) + (+ car-size tail-size)))) + (call-with-values + (lambda () + (expand (cons car-field first-word) + (+ car-size word-size) + (cdr fields))) + (lambda (tail tail-size) + (values (if (zero? car-size) + (cons car-field tail) + tail) + (+ car-size tail-size))))))) + (values '() 0)))) + +(define (expand-field field early? environment) early? ; ignored for now (let ((size (car field)) (expression (cadr field))) (define (default type) - (receiver (integer-syntaxer expression type size) - size)) + (values (integer-syntaxer expression environment type size) + size)) - (if (null? (cddr field)) - (default 'UNSIGNED) + (if (pair? (cddr field)) (case (caddr field) ((PC-REL) - (receiver - (integer-syntaxer ``(- ,,expression (+ *PC* 4)) - (cadddr field) - size) - size)) + (values (integer-syntaxer ``(,',(close-syntax '- environment) + ,,expression + (,',(close-syntax '+ environment) + ,',(close-syntax '*PC* environment) + 4)) + environment + (cadddr field) + size) + size)) ((BLOCK-OFFSET) - (receiver (list 'list ''BLOCK-OFFSET expression) - size)) + (values `(,(close-syntax 'LIST environment) + 'BLOCK-OFFSET + ,expression) + size)) (else - (default (caddr field))))))) \ No newline at end of file + (default (caddr field)))) + (default 'UNSIGNED)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/insmac.scm b/v7/src/compiler/machines/bobcat/insmac.scm index 7ae872281..36722d232 100644 --- a/v7/src/compiler/machines/bobcat/insmac.scm +++ b/v7/src/compiler/machines/bobcat/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.131 2002/02/14 15:58:56 cph Exp $ +$Id: insmac.scm,v 1.132 2002/02/14 22:03:32 cph Exp $ Copyright (c) 1988, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology @@ -41,30 +41,29 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (make-position-independent pattern actions environment)))))))) (define-syntax extension-word - (sc-macro-transformer + (rsc-macro-transformer (lambda (form environment) environment (call-with-values (lambda () (expand-descriptors (cdr form) environment)) (lambda (instruction size source destination) (if (or source destination) - (error "Source or destination used" 'EXTENSION-WORD)) + (error "Source or destination used:" form)) (if (not (zero? (remainder size 16))) - (error "EXTENSION-WORD: Extensions must be 16 bit multiples" - size)) - (optimize-group-syntax instruction #f)))))) + (error "Extensions must be 16 bit multiples:" size)) + (optimize-group-syntax instruction #f environment)))))) (define-syntax variable-extension - (sc-macro-transformer + (rsc-macro-transformer (lambda (form environment) (let ((binding (cadr form)) (clauses (cddr form))) (variable-width-expression-syntaxer (car binding) - (close-syntax (cadr binding) environment) + (cadr binding) + environment (map (lambda (clause) - `((LIST ,(make-syntactic-closure environment - (list (car binding)) - (caddr clause))) + `((,(close-syntax 'LIST environment) + ,(caddr clause)) ,(cadr clause) ,@(car clause))) clauses)))))) @@ -77,8 +76,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (extension (cdddr actions))) `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment) ',keyword - ,(integer-syntaxer mode 'UNSIGNED 3) - ,(integer-syntaxer register 'UNSIGNED 3) + ,(integer-syntaxer mode environment 'UNSIGNED 3) + ,(integer-syntaxer register environment 'UNSIGNED 3) (,(close-syntax 'LAMBDA environment) (IMMEDIATE-SIZE INSTRUCTION-TAIL) IMMEDIATE-SIZE ;ignore if not referenced @@ -117,15 +116,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (process-ea-field field environment) (if (exact-integer? field) - (integer-syntaxer field 'UNSIGNED 3) + (integer-syntaxer field environment 'UNSIGNED 3) (let ((binding (cadr field)) (clauses (cddr field))) (variable-width-expression-syntaxer (car binding) (cadr binding) + environment (map (lambda (clause) `((,(close-syntax 'LIST environment) - ,(integer-syntaxer (cadr clause) 'UNSIGNED 3)) + ,(integer-syntaxer (cadr clause) environment 'UNSIGNED 3)) 3 ,@(car clause))) clauses))))) @@ -225,7 +225,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA `(LIST ,(variable-width-expression-syntaxer (car binding) - (close-syntax (cadr binding) environment) + (cadr binding) + environment (map (lambda (clause) (if (pair? (cddr clause)) (error "Extension found in clause:" clause)) @@ -289,9 +290,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ,code)) (else (error "PARSE-WORD: multiple tail elements" tail)))))) - (if (not (null? instruction)) + (if (pair? instruction) `(,(if (null? code) 'CONS 'CONS-SYNTAX) - ,(optimize-group-syntax instruction early-instruction-parsing?) + ,(optimize-group-syntax instruction + early-instruction-parsing? + environment) ,code) code))) @@ -314,7 +317,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (handle))) (define (with-early-selectors handle) - (fluid-let ((early-instruction-parsing? true) + (fluid-let ((early-instruction-parsing? #t) (ea-keyword-selector 'EA-KEYWORD-EARLY) (ea-categories-selector 'EA-CATEGORIES-EARLY) (ea-mode-selector 'EA-MODE-EARLY) @@ -329,30 +332,43 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (if (pair? (cddr descriptor)) (caddr descriptor) 'UNSIGNED))) (case coercion-type ((UNSIGNED SIGNED SHIFT-NUMBER QUICK BFWIDTH SCALE-FACTOR) - (values `(,(integer-syntaxer expression coercion-type size)) + (values `(,(integer-syntaxer expression environment coercion-type size)) size #f #f)) ((SHORT-LABEL) - (values `(,(integer-syntaxer ``(- ,,expression (+ *PC* 2)) + (values `(,(integer-syntaxer ``(,',(close-syntax '- environment) + ,,expression + (,',(close-syntax '+ environment) + ,',(close-syntax '*PC* environment) + 2)) + environment 'SHORT-LABEL size)) size #f #f)) ((SOURCE-EA) - (values `((,ea-mode-selector ,expression) - (,ea-register-selector ,expression)) + (values `((,(close-syntax ea-mode-selector environment) ,expression) + (,(close-syntax ea-register-selector environment) + ,expression)) size - `((,ea-extension-selector ,expression) ,(cadddr descriptor)) + `((,(close-syntax ea-extension-selector environment) + ,expression) + ,(cadddr descriptor)) #f)) ((DESTINATION-EA) - (values `((,ea-mode-selector ,expression) - (,ea-register-selector ,expression)) + (values `((,(close-syntax ea-mode-selector environment) ,expression) + (,(close-syntax ea-register-selector environment) + ,expression)) size #f - `((,ea-extension-selector ,expression) '()))) + `((,(close-syntax ea-extension-selector environment) + ,expression) + '()))) ((DESTINATION-EA-REVERSED) - (values `((,ea-register-selector ,expression) - (,ea-mode-selector ,expression)) + (values `((,(close-syntax ea-register-selector environment) ,expression) + (,(close-syntax ea-mode-selector environment) ,expression)) size #f - `((,ea-extension-selector ,expression) '()))) + `((,(close-syntax ea-extension-selector environment) + ,expression) + '()))) (else (error "Badly-formed descriptor:" descriptor))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/i386/insmac.scm b/v7/src/compiler/machines/i386/insmac.scm index 808562682..8b598954c 100644 --- a/v7/src/compiler/machines/i386/insmac.scm +++ b/v7/src/compiler/machines/i386/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.16 2002/02/14 15:58:08 cph Exp $ +$Id: insmac.scm,v 1.17 2002/02/14 22:03:32 cph Exp $ Copyright (c) 1992, 1999, 2001, 2002 Massachusetts Institute of Technology @@ -56,8 +56,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment) ',keyword ',categories - ,(integer-syntaxer mode 'UNSIGNED 2) - ,(integer-syntaxer register 'UNSIGNED 3) + ,(integer-syntaxer mode environment 'UNSIGNED 2) + ,(integer-syntaxer register environment 'UNSIGNED 3) ,(if (null? tail) `() (process-fields tail #f environment)))))))))) @@ -104,6 +104,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ,(variable-width-expression-syntaxer (car binding) (cadr binding) + environment (map (lambda (clause) (call-with-values (lambda () (expand-fields (cdr clause) early? environment)) @@ -139,7 +140,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (values `(,(close-syntax 'CONS-SYNTAX environment) (,(close-syntax 'EA/REGISTER environment) ,r/m) (,(close-syntax 'CONS-SYNTAX environment) - ,(integer-syntaxer digit-or-reg 'UNSIGNED 3) + ,(integer-syntaxer digit-or-reg environment + 'UNSIGNED 3) (,(close-syntax 'CONS-SYNTAX environment) (,(close-syntax 'EA/MODE environment) ,r/m) (,(close-syntax 'APPEND-SYNTAX! environment) @@ -160,6 +162,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA `(,(close-syntax 'CONS-SYNTAX environment) ,(integer-syntaxer value + environment domain (case mode ((OPERAND) *operand-size*) @@ -182,7 +185,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (caddar components) 'UNSIGNED))) (values `(,(close-syntax 'CONS-SYNTAX environment) - ,(integer-syntaxer expression type size) + ,(integer-syntaxer expression environment type size) ,byte-tail) (+ size byte-size))))) (values tail 0)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/mips/insmac.scm b/v7/src/compiler/machines/mips/insmac.scm index fae2d92cb..4fd30dc3c 100644 --- a/v7/src/compiler/machines/mips/insmac.scm +++ b/v7/src/compiler/machines/mips/insmac.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.5 2001/12/23 17:20:58 cph Exp $ +$Id: insmac.scm,v 1.6 2002/02/14 22:03:32 cph Exp $ -Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -27,110 +27,121 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Definition macros (define-syntax define-symbol-transformer - (non-hygienic-macro-transformer - (lambda (name . alist) - `(DEFINE-INTEGRABLE (,name SYMBOL) - (LET ((PLACE (ASSQ SYMBOL ',alist))) - (IF (PAIR? PLACE) - (CDR PLACE) - #F)))))) + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form)) + `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL) + (LET ((PLACE (ASSQ SYMBOL ',(cddr form)))) + (IF (PAIR? PLACE) + (CDR PLACE) + #F))) + (ill-formed-syntax form))))) (define-syntax define-transformer - (non-hygienic-macro-transformer - (lambda (name value) - `(DEFINE ,name ,value)))) + (rsc-macro-transformer + (lambda (form environment) + `(,(close-syntax 'DEFINE environment) ,@(cdr form))))) ;;;; Fixed width instruction parsing -(define (parse-instruction first-word tail early?) +(define (parse-instruction first-word tail early? environment) (if (not (null? tail)) - (error "parse-instruction: Unknown format" (cons first-word tail))) + (error "Unknown format:" (cons first-word tail))) (let loop ((first-word first-word)) (case (car first-word) ((LONG) - (process-fields (cdr first-word) early?)) + (process-fields (cdr first-word) early? environment)) ((VARIABLE-WIDTH) - (process-variable-width first-word early?)) + (process-variable-width first-word early? environment)) ((IF) - `(IF ,(cadr first-word) - ,(loop (caddr first-word)) - ,(loop (cadddr first-word)))) + `(,(close-syntax 'IF environment) + ,(cadr first-word) + ,(loop (caddr first-word)) + ,(loop (cadddr first-word)))) (else - (error "parse-instruction: Unknown format" first-word))))) + (error "Unknown format:" first-word))))) -(define (process-variable-width descriptor early?) +(define (process-variable-width descriptor early? environment) (let ((binding (cadr descriptor)) (clauses (cddr descriptor))) - `(LIST + `(,(close-syntax 'LIST environment) ,(variable-width-expression-syntaxer (car binding) ; name (cadr binding) ; expression + environment (map (lambda (clause) - (expand-fields - (cdadr clause) - early? - (lambda (code size) - (if (not (zero? (remainder size 32))) - (error "process-variable-width: bad clause size" size)) - `((LIST ,(optimize-group-syntax code early?)) - ,size - ,@(car clause))))) - clauses))))) - -(define (process-fields fields early?) - (expand-fields fields - early? + (call-with-values + (lambda () + (expand-fields (cdadr clause) early? environment)) (lambda (code size) (if (not (zero? (remainder size 32))) - (error "process-fields: bad syllable size" size)) - `(LIST ,(optimize-group-syntax code early?))))) - -(define (expand-fields fields early? receiver) - (define (expand first-word word-size fields receiver) - (if (null? fields) - (receiver '() 0) - (expand-field - (car fields) early? - (lambda (car-field car-size) - (if (and (eq? endianness 'LITTLE) - (= 32 (+ word-size car-size))) - (expand '() 0 (cdr fields) - (lambda (tail tail-size) - (receiver - (append (cons car-field first-word) tail) - (+ car-size tail-size)))) - (expand (cons car-field first-word) - (+ car-size word-size) - (cdr fields) - (lambda (tail tail-size) - (receiver - (if (or (zero? car-size) - (not (eq? endianness 'LITTLE))) - (cons car-field tail) - tail) - (+ car-size tail-size))))))))) - (expand '() 0 fields receiver)) - -(define (expand-field field early? receiver) + (error "Bad clause size:" size)) + `((,(close-syntax 'LIST environment) + ,(optimize-group-syntax code early? environment)) + ,size + ,@(car clause))))) + clauses))))) + +(define (process-fields fields early? environment) + (call-with-values (lambda () (expand-fields fields early? environment)) + (lambda (code size) + (if (not (zero? (remainder size 32))) + (error "Bad syllable size:" size)) + `(,(close-syntax 'LIST environment) + ,(optimize-group-syntax code early? environment))))) + +(define (expand-fields fields early? environment) + (let expand ((first-word '()) (word-size 0) (fields fields)) + (if (pair? fields) + (call-with-values + (lambda () (expand-field (car fields) early? environment)) + (lambda (car-field car-size) + (if (and (eq? endianness 'LITTLE) + (= 32 (+ word-size car-size))) + (call-with-values (lambda () (expand '() 0 (cdr fields))) + (lambda (tail tail-size) + (values (append (cons car-field first-word) tail) + (+ car-size tail-size)))) + (call-with-values + (lambda () + (expand (cons car-field first-word) + (+ car-size word-size) + (cdr fields))) + (lambda (tail tail-size) + (values (if (or (zero? car-size) + (not (eq? endianness 'LITTLE))) + (cons car-field tail) + tail) + (+ car-size tail-size))))))) + (values '() 0)))) + +(define (expand-field field early? environment) early? ; ignored for now (let ((size (car field)) (expression (cadr field))) (define (default type) - (receiver (integer-syntaxer expression type size) - size)) + (values (integer-syntaxer expression environment type size) + size)) - (if (null? (cddr field)) - (default 'UNSIGNED) + (if (pair? (cddr field)) (case (caddr field) ((PC-REL) - (receiver - (integer-syntaxer ``(- ,,expression (+ *PC* 4)) - (cadddr field) - size) - size)) + (values (integer-syntaxer ``(,',(close-syntax '- environment) + ,,expression + (,',(close-syntax '+ environment) + ,',(close-syntax '*PC* environment) + 4)) + environment + (cadddr field) + size) + size)) ((BLOCK-OFFSET) - (receiver (list 'list ''BLOCK-OFFSET expression) - size)) + (values `(,(close-syntax 'LIST environment) + 'BLOCK-OFFSET + ,expression) + size)) (else - (default (caddr field))))))) \ No newline at end of file + (default (caddr field)))) + (default 'UNSIGNED)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/insmac.scm b/v7/src/compiler/machines/sparc/insmac.scm index e17576830..25abb0b9d 100644 --- a/v7/src/compiler/machines/sparc/insmac.scm +++ b/v7/src/compiler/machines/sparc/insmac.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.4 2001/12/23 17:20:58 cph Exp $ +$Id: insmac.scm,v 1.5 2002/02/14 22:03:32 cph Exp $ -Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -27,110 +27,121 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Definition macros (define-syntax define-symbol-transformer - (non-hygienic-macro-transformer - (lambda (name . alist) - `(DEFINE-INTEGRABLE (,name SYMBOL) - (LET ((PLACE (ASSQ SYMBOL ',alist))) - (IF (PAIR? PLACE) - (CDR PLACE) - #F)))))) + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form)) + `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL) + (LET ((PLACE (ASSQ SYMBOL ',(cddr form)))) + (IF (PAIR? PLACE) + (CDR PLACE) + #F))) + (ill-formed-syntax form))))) (define-syntax define-transformer - (non-hygienic-macro-transformer - (lambda (name value) - `(DEFINE ,name ,value)))) + (rsc-macro-transformer + (lambda (form environment) + `(,(close-syntax 'DEFINE environment) ,@(cdr form))))) ;;;; Fixed width instruction parsing -(define (parse-instruction first-word tail early?) +(define (parse-instruction first-word tail early? environment) (if (not (null? tail)) - (error "parse-instruction: Unknown format" (cons first-word tail))) + (error "Unknown format:" (cons first-word tail))) (let loop ((first-word first-word)) (case (car first-word) ((LONG) - (process-fields (cdr first-word) early?)) + (process-fields (cdr first-word) early? environment)) ((VARIABLE-WIDTH) - (process-variable-width first-word early?)) + (process-variable-width first-word early? environment)) ((IF) - `(IF ,(cadr first-word) - ,(loop (caddr first-word)) - ,(loop (cadddr first-word)))) + `(,(close-syntax 'IF environment) + ,(cadr first-word) + ,(loop (caddr first-word)) + ,(loop (cadddr first-word)))) (else - (error "parse-instruction: Unknown format" first-word))))) + (error "Unknown format:" first-word))))) -(define (process-variable-width descriptor early?) +(define (process-variable-width descriptor early? environment) (let ((binding (cadr descriptor)) (clauses (cddr descriptor))) - `(LIST + `(,(close-syntax 'LIST environment) ,(variable-width-expression-syntaxer (car binding) ; name (cadr binding) ; expression + environment (map (lambda (clause) - (expand-fields - (cdadr clause) - early? - (lambda (code size) - (if (not (zero? (remainder size 32))) - (error "process-variable-width: bad clause size" size)) - `((LIST ,(optimize-group-syntax code early?)) - ,size - ,@(car clause))))) - clauses))))) - -(define (process-fields fields early?) - (expand-fields fields - early? + (call-with-values + (lambda () + (expand-fields (cdadr clause) early? environment)) (lambda (code size) (if (not (zero? (remainder size 32))) - (error "process-fields: bad syllable size" size)) - `(LIST ,(optimize-group-syntax code early?))))) - -(define (expand-fields fields early? receiver) - (define (expand first-word word-size fields receiver) - (if (null? fields) - (receiver '() 0) - (expand-field - (car fields) early? - (lambda (car-field car-size) - (if (and (eq? endianness 'LITTLE) - (= 32 (+ word-size car-size))) - (expand '() 0 (cdr fields) - (lambda (tail tail-size) - (receiver - (append (cons car-field first-word) tail) - (+ car-size tail-size)))) - (expand (cons car-field first-word) - (+ car-size word-size) - (cdr fields) - (lambda (tail tail-size) - (receiver - (if (or (zero? car-size) - (not (eq? endianness 'LITTLE))) - (cons car-field tail) - tail) - (+ car-size tail-size))))))))) - (expand '() 0 fields receiver)) - -(define (expand-field field early? receiver) + (error "Bad clause size:" size)) + `((,(close-syntax 'LIST environment) + ,(optimize-group-syntax code early? environment)) + ,size + ,@(car clause))))) + clauses))))) + +(define (process-fields fields early? environment) + (call-with-values (lambda () (expand-fields fields early? environment)) + (lambda (code size) + (if (not (zero? (remainder size 32))) + (error "Bad syllable size:" size)) + `(,(close-syntax 'LIST environment) + ,(optimize-group-syntax code early? environment))))) + +(define (expand-fields fields early? environment) + (let expand ((first-word '()) (word-size 0) (fields fields)) + (if (pair? fields) + (call-with-values + (lambda () (expand-field (car fields) early? environment)) + (lambda (car-field car-size) + (if (and (eq? endianness 'LITTLE) + (= 32 (+ word-size car-size))) + (call-with-values (lambda () (expand '() 0 (cdr fields))) + (lambda (tail tail-size) + (values (append (cons car-field first-word) tail) + (+ car-size tail-size)))) + (call-with-values + (lambda () + (expand (cons car-field first-word) + (+ car-size word-size) + (cdr fields))) + (lambda (tail tail-size) + (values (if (or (zero? car-size) + (not (eq? endianness 'LITTLE))) + (cons car-field tail) + tail) + (+ car-size tail-size))))))) + (values '() 0)))) + +(define (expand-field field early? environment) early? ; ignored for now (let ((size (car field)) (expression (cadr field))) (define (default type) - (receiver (integer-syntaxer expression type size) - size)) + (values (integer-syntaxer expression environment type size) + size)) - (if (null? (cddr field)) - (default 'UNSIGNED) + (if (pair? (cddr field)) (case (caddr field) ((PC-REL) - (receiver - (integer-syntaxer ``(- ,,expression (+ *PC* 4)) - (cadddr field) - size) - size)) + (values (integer-syntaxer ``(,',(close-syntax '- environment) + ,,expression + (,',(close-syntax '+ environment) + ,',(close-syntax '*PC* environment) + 4)) + environment + (cadddr field) + size) + size)) ((BLOCK-OFFSET) - (receiver (list 'list ''BLOCK-OFFSET expression) - size)) + (values `(,(close-syntax 'LIST environment) + 'BLOCK-OFFSET + ,expression) + size)) (else - (default (caddr field))))))) \ No newline at end of file + (default (caddr field)))) + (default 'UNSIGNED)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/insmac.scm b/v7/src/compiler/machines/spectrum/insmac.scm index f86f829cf..49cfe2eb5 100644 --- a/v7/src/compiler/machines/spectrum/insmac.scm +++ b/v7/src/compiler/machines/spectrum/insmac.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.5 2001/12/23 17:20:58 cph Exp $ +$Id: insmac.scm,v 1.6 2002/02/14 22:03:32 cph Exp $ -Copyright (c) 1988, 1989, 1990, 1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1988-1990, 1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -27,104 +27,112 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Definition macros (define-syntax define-symbol-transformer - (non-hygienic-macro-transformer - (lambda (name . alist) - `(DEFINE-INTEGRABLE (,name SYMBOL) - (LET ((PLACE (ASSQ SYMBOL ',alist))) - (IF (PAIR? PLACE) - (CDR PLACE) - #F)))))) + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form)) + `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL) + (LET ((PLACE (ASSQ SYMBOL ',(cddr form)))) + (IF (PAIR? PLACE) + (CDR PLACE) + #F))) + (ill-formed-syntax form))))) (define-syntax define-transformer - (non-hygienic-macro-transformer - (lambda (name value) - `(DEFINE ,name ,value)))) + (rsc-macro-transformer + (lambda (form environment) + `(,(close-syntax 'DEFINE environment) ,@(cdr form))))) ;;;; Fixed width instruction parsing -(define (parse-instruction first-word tail early?) - (cond ((not (null? tail)) - (error "parse-instruction: Unknown format" (cons first-word tail))) - ((eq? (car first-word) 'LONG) - (process-fields (cdr first-word) early?)) - ((eq? (car first-word) 'VARIABLE-WIDTH) - (process-variable-width first-word early?)) - (else - (error "parse-instruction: Unknown format" first-word)))) - -(define (process-variable-width descriptor early?) +(define (parse-instruction first-word tail early? environment) + (if (not (null? tail)) + (error "Unknown format:" (cons first-word tail))) + (case (car first-word) + ((LONG) (process-fields (cdr first-word) early? environment)) + ((VARIABLE-WIDTH) (process-variable-width first-word early? environment)) + (else (error "Unknown format:" first-word)))) + +(define (process-variable-width descriptor early? environment) (let ((binding (cadr descriptor)) (clauses (cddr descriptor))) - `(LIST + `(,(close-syntax 'LIST environment) ,(variable-width-expression-syntaxer (car binding) ; name (cadr binding) ; expression + environment (map (lambda (clause) - (expand-fields - (cdadr clause) - early? - (lambda (code size) - (if (not (zero? (remainder size 32))) - (error "process-variable-width: bad clause size" size)) - `((LIST ,(optimize-group-syntax code early?)) - ,size - ,@(car clause))))) - clauses))))) - -(define (process-fields fields early?) - (expand-fields fields - early? + (call-with-values + (lambda () + (expand-fields (cdadr clause) early? environment)) (lambda (code size) (if (not (zero? (remainder size 32))) - (error "process-fields: bad syllable size" size)) - `(LIST ,(optimize-group-syntax code early?))))) - -(define (expand-fields fields early? receiver) - (define (expand first-word word-size fields receiver) - (if (null? fields) - (receiver '() 0) - (expand-field - (car fields) early? - (lambda (car-field car-size) - (if (and (eq? endianness 'LITTLE) - (= 32 (+ word-size car-size))) - (expand '() 0 (cdr fields) - (lambda (tail tail-size) - (receiver - (append (cons car-field first-word) tail) - (+ car-size tail-size)))) - (expand (cons car-field first-word) - (+ car-size word-size) - (cdr fields) - (lambda (tail tail-size) - (receiver - (if (or (zero? car-size) - (not (eq? endianness 'LITTLE))) - (cons car-field tail) - tail) - (+ car-size tail-size))))))))) - (expand '() 0 fields receiver)) - -(define (expand-field field early? receiver) + (error "Bad clause size:" size)) + `((,(close-syntax 'LIST environment) + ,(optimize-group-syntax code early? environment)) + ,size + ,@(car clause))))) + clauses))))) + +(define (process-fields fields early? environment) + (call-with-values (lambda () (expand-fields fields early? environment)) + (lambda (code size) + (if (not (zero? (remainder size 32))) + (error "Bad syllable size:" size)) + `(,(close-syntax 'LIST environment) + ,(optimize-group-syntax code early? environment))))) + +(define (expand-fields fields early? environment) + (let expand ((first-word '()) (word-size 0) (fields fields)) + (if (pair? fields) + (call-with-values + (lambda () (expand-field (car fields) early? environment)) + (lambda (car-field car-size) + (if (and (eq? endianness 'LITTLE) + (= 32 (+ word-size car-size))) + (call-with-values (lambda () (expand '() 0 (cdr fields))) + (lambda (tail tail-size) + (values (append (cons car-field first-word) tail) + (+ car-size tail-size)))) + (call-with-values + (lambda () + (expand (cons car-field first-word) + (+ car-size word-size) + (cdr fields))) + (lambda (tail tail-size) + (values (if (or (zero? car-size) + (not (eq? endianness 'LITTLE))) + (cons car-field tail) + tail) + (+ car-size tail-size))))))) + (values '() 0)))) + +(define (expand-field field early? environment) early? ; ignored for now (let ((size (car field)) (expression (cadr field))) (define (default type) - (receiver (integer-syntaxer expression type size) - size)) + (values (integer-syntaxer expression environment type size) + size)) - (if (null? (cddr field)) - (default 'UNSIGNED) + (if (pair? (cddr field)) (case (caddr field) ((PC-REL) - (receiver - (integer-syntaxer ``(- ,,expression (+ *PC* 8)) - (cadddr field) - size) - size)) + (values (integer-syntaxer ``(,',(close-syntax '- environment) + ,,expression + (,',(close-syntax '+ environment) + ,',(close-syntax '*PC* environment) + 8)) + environment + (cadddr field) + size) + size)) ((BLOCK-OFFSET) - (receiver (list 'list ''BLOCK-OFFSET expression) - size)) + (values `(,(close-syntax 'LIST environment) + 'BLOCK-OFFSET + ,expression) + size)) (else - (default (caddr field))))))) \ No newline at end of file + (default (caddr field)))) + (default 'UNSIGNED)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/vax/insmac.scm b/v7/src/compiler/machines/vax/insmac.scm index 0fa772135..930cc7fa6 100644 --- a/v7/src/compiler/machines/vax/insmac.scm +++ b/v7/src/compiler/machines/vax/insmac.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.15 2001/12/23 17:20:58 cph Exp $ +$Id: insmac.scm,v 1.16 2002/02/14 22:03:32 cph Exp $ -Copyright (c) 1987, 1989, 1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1987, 1989, 1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -30,132 +30,138 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 'EA-DATABASE) (define-syntax define-ea-database - (non-hygienic-macro-transformer - (lambda rules - `(DEFINE ,ea-database-name - ,(compile-database rules + (rsc-macro-transformer + (lambda (form environment) + `(,(close-syntax 'DEFINE environment) + ,ea-database-name + ,(compile-database (cdr form) environment (lambda (pattern actions) (let ((keyword (car pattern)) (categories (car actions)) (value (cdr actions))) - (declare (integrate keyword categories value)) - `(MAKE-EFFECTIVE-ADDRESS + `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment) ',keyword ',categories - ,(process-fields value false))))))))) + ,(process-fields value #f environment))))))))) (define-syntax define-ea-transformer - (non-hygienic-macro-transformer - (lambda (name category type) - `(DEFINE (,name EXPRESSION) - (LET ((EA (PROCESS-EA EXPRESSION ',type))) - (AND EA - (MEMQ ',category (EA-CATEGORIES EA)) - EA)))))) + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(IDENTIFIER DATUM DATUM) (cdr form)) + `(DEFINE (,(cadr form) EXPRESSION) + (LET ((EA (PROCESS-EA EXPRESSION ',(cadddr form)))) + (AND EA + (MEMQ ',(caddr form) (EA-CATEGORIES EA)) + EA))) + (ill-formed-syntax form))))) (define-syntax define-symbol-transformer - (non-hygienic-macro-transformer - (lambda (name . alist) - `(DEFINE-INTEGRABLE (,name SYMBOL) - (LET ((PLACE (ASSQ SYMBOL ',alist))) - (IF (PAIR? PLACE) - (CDR PLACE) - #F)))))) + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form)) + `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL) + (LET ((PLACE (ASSQ SYMBOL ',(cddr form)))) + (IF (PAIR? PLACE) + (CDR PLACE) + #F))) + (ill-formed-syntax form))))) (define-syntax define-transformer - (non-hygienic-macro-transformer - (lambda (name value) - `(DEFINE ,name ,value)))) + (rsc-macro-transformer + (lambda (form environment) + `(,(close-syntax 'DEFINE environment) ,@(cdr form))))) -(define (parse-instruction opcode tail early?) - (process-fields (cons opcode tail) early?)) +(define (parse-instruction opcode tail early? environment) + (process-fields (cons opcode tail) early? environment)) -(define (process-fields fields early?) +(define (process-fields fields early? environment) (if (and (null? (cdr fields)) (eq? (caar fields) 'VARIABLE-WIDTH)) - (expand-variable-width (car fields) early?) - (expand-fields fields - early? - (lambda (code size) - (if (not (zero? (remainder size 8))) - (error "process-fields: bad syllable size" size)) - code)))) + (expand-variable-width (car fields) early? environment) + (call-with-values (lambda () (expand-fields fields early? environment)) + (lambda (code size) + (if (not (zero? (remainder size 8))) + (error "Bad syllable size:" size)) + code)))) -(define (expand-variable-width field early?) +(define (expand-variable-width field early? environment) (let ((binding (cadr field)) (clauses (cddr field))) - `(LIST + `(,(close-syntax 'LIST environment) ,(variable-width-expression-syntaxer (car binding) ; name (cadr binding) ; expression + environment (map (lambda (clause) - (expand-fields - (cdr clause) - early? - (lambda (code size) - (if (not (zero? (remainder size 8))) - (error "expand-variable-width: bad clause size" size)) - `(,code ,size ,@(car clause))))) + (call-with-values + (lambda () (expand-fields (cdr clause) early? environment)) + (lambda (code size) + (if (not (zero? (remainder size 8))) + (error "Bad clause size:" size)) + `(,code ,size ,@(car clause))))) clauses))))) -(define (expand-fields fields early? receiver) - (if (null? fields) - (receiver ''() 0) - (expand-fields (cdr fields) early? - (lambda (tail tail-size) - (case (caar fields) - ((BYTE) - (collect-byte (cdar fields) - tail - (lambda (code size) - (receiver code (+ size tail-size))))) - ((OPERAND) - (receiver - `(APPEND-SYNTAX! - ,(if early? - `(EA-VALUE-EARLY ',(cadar fields) ,(caddar fields)) - `(EA-VALUE ,(caddar fields))) - ,tail) - tail-size)) - ;; Displacements are like signed bytes. They are a different - ;; keyword to allow the disassembler to do its thing correctly. - ((DISPLACEMENT) - (let* ((desc (cadar fields)) - (size (car desc))) - (receiver - `(CONS-SYNTAX ,(integer-syntaxer (cadr desc) 'SIGNED size) - ,tail) - (+ size tail-size)))) - ((IMMEDIATE) - (receiver - `(CONS-SYNTAX - (COERCE-TO-TYPE ,(cadar fields) - *IMMEDIATE-TYPE* - ,(and (cddar fields) - (eq? (caddar fields) - 'UNSIGNED))) - ,tail) - tail-size)) - (else - (error "expand-fields: Unknown field kind" (caar fields)))))))) - -(define (collect-byte components tail receiver) - (define (inner components receiver) - (if (null? components) - (receiver tail 0) - (inner (cdr components) - (lambda (byte-tail byte-size) - (let ((size (caar components)) - (expression (cadar components)) - (type (if (null? (cddar components)) - 'UNSIGNED - (caddar components)))) - (receiver - `(CONS-SYNTAX - ,(integer-syntaxer expression type size) - ,byte-tail) - (+ size byte-size))))))) - (inner components receiver)) - - +(define (expand-fields fields early? environment) + (if (pair? fields) + (call-with-values + (lambda () (expand-fields (cdr fields) early? environment)) + (lambda (tail tail-size) + (case (caar fields) + ((BYTE) + (call-with-values + (lambda () (collect-byte (cdar fields) tail environment)) + (lambda (code size) + (values code (+ size tail-size))))) + ((OPERAND) + (values `(,(close-syntax 'APPEND-SYNTAX! environment) + ,(if early? + `(,(close-syntax 'EA-VALUE-EARLY environment) + ',(cadar fields) + ,(caddar fields)) + `(,(close-syntax 'EA-VALUE environment) + ,(caddar fields))) + ,tail) + tail-size)) + ;; Displacements are like signed bytes. They are a + ;; different keyword to allow the disassembler to do its + ;; thing correctly. + ((DISPLACEMENT) + (let* ((desc (cadar fields)) + (size (car desc))) + (values `(,(close-syntax 'CONS-SYNTAX environment) + ,(integer-syntaxer (cadr desc) + environment + 'SIGNED + size) + ,tail) + (+ size tail-size)))) + ((IMMEDIATE) + (values `(,(close-syntax 'CONS-SYNTAX environment) + (,(close-syntax 'COERCE-TO-TYPE environment) + ,(cadar fields) + ,(close-syntax '*IMMEDIATE-TYPE* environment) + ,(and (cddar fields) + (eq? (caddar fields) 'UNSIGNED))) + ,tail) + tail-size)) + (else + (error "Unknown field kind:" (caar fields)))))) + (values `'() 0))) +(define (collect-byte components tail environment) + (let inner ((components components)) + (if (pair? components) + (call-with-values (lambda () (inner (cdr components))) + (lambda (byte-tail byte-size) + (let ((size (caar components)) + (expression (cadar components)) + (type (if (pair? (cddar components)) + (caddar components) + 'UNSIGNED))) + (values `(,(close-syntax 'CONS-SYNTAX environment) + ,(integer-syntaxer expression environment type size) + ,byte-tail) + (+ size byte-size))))) + (values tail 0)))) \ No newline at end of file -- 2.25.1