From 5af2072191bbccc3b9c6164e36c6be97581344d3 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 13 Feb 2002 18:45:24 +0000 Subject: [PATCH] Eliminate non-hygienic macros. --- v7/src/compiler/machines/bobcat/insmac.scm | 376 +++++++++++---------- 1 file changed, 200 insertions(+), 176 deletions(-) diff --git a/v7/src/compiler/machines/bobcat/insmac.scm b/v7/src/compiler/machines/bobcat/insmac.scm index 572f16446..d5ebbf515 100644 --- a/v7/src/compiler/machines/bobcat/insmac.scm +++ b/v7/src/compiler/machines/bobcat/insmac.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.129 2001/12/23 17:20:57 cph Exp $ +$Id: insmac.scm,v 1.130 2002/02/13 18:45:24 cph Exp $ -Copyright (c) 1988, 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 @@ -30,72 +30,63 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 'EA-DATABASE) (define-syntax define-ea-database - (non-hygienic-macro-transformer - (lambda rules + (sc-macro-transformer + (lambda (form environment) `(DEFINE ,ea-database-name - ,(compile-database rules + ,(compile-database (cdr form) environment (lambda (pattern actions) (if (null? (cddr actions)) - (make-position-dependent pattern actions) - (make-position-independent pattern actions)))))))) + (make-position-dependent pattern actions environment) + (make-position-independent pattern actions environment)))))))) (define-syntax extension-word - (non-hygienic-macro-transformer - (lambda descriptors - (expand-descriptors descriptors + (sc-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) - (if (zero? (remainder size 16)) - (optimize-group-syntax instruction false) - (error "EXTENSION-WORD: Extensions must be 16 bit multiples" - size)))))))) + (error "Source or destination used" 'EXTENSION-WORD)) + (if (not (zero? (remainder size 16))) + (error "EXTENSION-WORD: Extensions must be 16 bit multiples" + size)) + (optimize-group-syntax instruction #f)))))) (define-syntax variable-extension - (non-hygienic-macro-transformer - (lambda (binding . clauses) - (variable-width-expression-syntaxer - (car binding) - (cadr binding) - (map (lambda (clause) - `((LIST ,(caddr clause)) - ,(cadr clause) - ,@(car clause))) - clauses))))) + (sc-macro-transformer + (lambda (form environment) + (let ((binding (cadr form)) + (clauses (cddr form))) + (variable-width-expression-syntaxer + (car binding) + (close-syntax (cadr binding) environment) + (map (lambda (clause) + `((LIST ,(make-syntactic-closure environment + (list (car binding)) + (caddr clause))) + ,(cadr clause) + ,@(car clause))) + clauses)))))) -(define (make-position-independent pattern actions) +(define (make-position-independent pattern actions environment) (let ((keyword (car pattern)) (categories (car actions)) (mode (cadr actions)) (register (caddr actions)) (extension (cdddr actions))) - ;;(declare (integrate keyword categories mode register extension)) `(MAKE-EFFECTIVE-ADDRESS ',keyword - ,(integer-syntaxer mode 'UNSIGNED 3) - ,(integer-syntaxer register 'UNSIGNED 3) + ,(integer-syntaxer (close-syntax mode environment) 'UNSIGNED 3) + ,(integer-syntaxer (close-syntax register environment) 'UNSIGNED 3) (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL) IMMEDIATE-SIZE ;ignore if not referenced - ,(if (null? extension) - 'INSTRUCTION-TAIL - `(CONS-SYNTAX ,(car extension) INSTRUCTION-TAIL))) + ,(if (pair? extension) + `(CONS-SYNTAX ,(close-syntax (car extension) environment) + INSTRUCTION-TAIL) + 'INSTRUCTION-TAIL)) ',categories))) -(define (process-ea-field field) - (if (exact-integer? field) - (integer-syntaxer field 'UNSIGNED 3) - (let ((binding (cadr field)) - (clauses (cddr field))) - (variable-width-expression-syntaxer - (car binding) - (cadr binding) - (map (lambda (clause) - `((LIST ,(integer-syntaxer (cadr clause) 'UNSIGNED 3)) - 3 - ,@(car clause))) - clauses))))) - -(define (make-position-dependent pattern actions) +(define (make-position-dependent pattern actions environment) (let ((keyword (car pattern)) (categories (car actions)) (code (cdr (cadr actions)))) @@ -106,108 +97,137 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA `(LET ((,name (GENERATE-LABEL 'MARK))) (make-effective-address ',keyword - ,(process-ea-field mode) - ,(process-ea-field register) + ,(process-ea-field mode environment) + ,(process-ea-field register environment) (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL) IMMEDIATE-SIZE ;ignore if not referenced - ,(if (null? extension) - 'INSTRUCTION-TAIL - `(CONS (LIST 'LABEL ,name) - (CONS-SYNTAX ,extension INSTRUCTION-TAIL)))) + ,(if (pair? extension) + `(CONS (LIST 'LABEL ,(close-syntax name environment)) + (CONS-SYNTAX ,(close-syntax extension environment) + INSTRUCTION-TAIL)) + `INSTRUCTION-TAIL)) ',categories))))) + +(define (process-ea-field field environment) + (if (exact-integer? field) + (integer-syntaxer field 'UNSIGNED 3) + (let ((binding (cadr field)) + (clauses (cddr field))) + (variable-width-expression-syntaxer + (car binding) + (close-syntax (cadr binding) environment) + (map (lambda (clause) + `((LIST + ,(integer-syntaxer (close-syntax (cadr clause) environment) + 'UNSIGNED 3)) + 3 + ,@(car clause))) + clauses))))) ;;;; Transformers (define-syntax define-ea-transformer - (non-hygienic-macro-transformer - (lambda (name #!optional categories keywords) - (define (filter special generator extraction) - (define (multiple rem) - (if (null? rem) - `() - `(,(generator (car rem) 'temp) - ,@(multiple (cdr rem))))) - - (cond ((null? special) - `()) - ((null? (cdr special)) - `(,(generator (car special) extraction))) - (else - `((let ((temp ,extraction)) - (and ,@(multiple special))))))) - - `(define (,name expression) - (let ((match-result (pattern-lookup ,ea-database-name expression))) - (and match-result - ,(if (default-object? categories) - `(match-result) - `(let ((ea (match-result))) - (and ,@(filter categories - (lambda (cat exp) `(memq ',cat ,exp)) - `(ea-categories ea)) - ,@(if (default-object? keywords) - `() - (filter keywords - (lambda (key exp) - `(not (eq? ',key ,exp))) - `(ea-keyword ea))) - ea))))))))) + (sc-macro-transformer + (lambda (form environment) + environment + (let ((filter + (lambda (items generator extraction) + (if (pair? items) + (if (pair? (cdr items)) + `((LET ((TEMP ,extraction)) + (AND + ,@(map (lambda (item) (generator item 'TEMP)) + items)))) + `(,(generator (car items) extraction))) + '())))) + (let ((generate-definition + (lambda (name generate-match) + `(DEFINE (,name EXPRESSION) + (LET ((MATCH-RESULT + (PATTERN-LOOKUP ,ea-database-name EXPRESSION))) + (AND MATCH-RESULT + ,(generate-match `(MATCH-RESULT))))))) + (filter-categories + (lambda (categories) + (filter categories + (lambda (cat exp) `(MEMQ ',cat ,exp)) + `(EA-CATEGORIES EA)))) + (filter-keywords + (lambda (keywords) + (filter keywords + (lambda (key exp) `(NOT (EQ? ',key ,exp))) + `(EA-KEYWORD EA))))) + (cond ((syntax-match? '(IDENTIFIER) (cdr form)) + (generate-definition (cadr form) + (lambda (ea) + ea))) + ((syntax-match? '(IDENTIFIER (* DATUM)) (cdr form)) + (generate-definition (cadr form) + (lambda (ea) + `(LET ((EA ,ea)) + (AND ,@(filter-categories (caddr form)) + EA))))) + ((syntax-match? '(IDENTIFIER (* DATUM) (* DATUM)) (cdr form)) + (generate-definition (cadr form) + (lambda (ea) + `(LET ((EA (MATCH-RESULT))) + (AND ,@(filter-categories (caddr form)) + ,@(filter-keywords (cadddr form)) + EA))))) + (else + (ill-formed-syntax form)))))))) (define-syntax define-symbol-transformer - (non-hygienic-macro-transformer - (lambda (name . alist) - `(begin - (declare (integrate-operator ,name)) - (define (,name symbol) - (declare (integrate symbol)) - (let ((place (assq symbol ',alist))) - (if (null? place) - #F - (cdr place)))))))) + (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-reg-list-transformer - (non-hygienic-macro-transformer - (lambda (name . alist) - `(begin - (declare (integrate-operator ,name)) - (define (,name reg-list) - (declare (integrate reg-list)) - (encode-register-list reg-list ',alist)))))) + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(IDENTIFIER * DATUM) (cdr form)) + `(DEFINE-INTEGRABLE (,(cadr form) REG-LIST) + (ENCODE-REGISTER-LIST REG-LIST ',(cddr form))) + (ill-formed-syntax form))))) ;;;; Utility procedures -(define (parse-instruction expression tail early?) +(define (parse-instruction expression tail early? environment) (define (kernel) (case (car expression) - ((WORD) - (parse-word expression tail)) - ((GROWING-WORD) - (parse-growing-word expression tail)) - (else - (error "PARSE-INSTRUCTION: unknown expression" expression)))) - + ((WORD) (parse-word expression tail environment)) + ((GROWING-WORD) (parse-growing-word expression tail environment)) + (else (error "Unknown expression:" expression)))) (if (not early?) (with-normal-selectors kernel) (with-early-selectors kernel))) ;;; Variable width instruction parsing -(define (parse-growing-word expression tail) +(define (parse-growing-word expression tail environment) (if (not (null? tail)) (error "PARSE-GROWING-WORD: non null tail" tail)) (let ((binding (cadr expression))) `(LIST ,(variable-width-expression-syntaxer (car binding) - (cadr binding) + (close-syntax (cadr binding) environment) (map (lambda (clause) - (if (not (null? (cddr clause))) - (error "Extension found in clause" clause)) - (expand-descriptors - (cdadr clause) + (if (pair? (cddr clause)) + (error "Extension found in clause:" clause)) + (call-with-values + (lambda () (expand-descriptors (cdadr clause) environment)) (lambda (instruction size src dst) (if (not (zero? (remainder size 16))) - (error "Instructions must be 16 bit multiples" size)) + (error "Instructions must be 16 bit multiples:" size)) `(,(collect-word instruction src dst '()) ,size ,@(car clause))))) ; Range @@ -215,12 +235,39 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Fixed width instruction parsing -(define (parse-word expression tail) - (expand-descriptors (cdr expression) - (lambda (instruction size src dst) - (if (zero? (remainder size 16)) - (collect-word instruction src dst tail) - (error "PARSE-WORD: Instructions must be 16 bit multiples" size))))) +(define (parse-word expression tail environment) + (call-with-values + (lambda () (expand-descriptors (cdr expression) environment)) + (lambda (instruction size src dst) + (if (not (zero? (remainder size 16))) + (error "Instructions must be 16 bit multiples:" size)) + (collect-word instruction src dst tail)))) + +(define (expand-descriptors descriptors environment) + (if (pair? descriptors) + (call-with-values + (lambda () (expand-descriptors (cdr descriptors) environment)) + (lambda (instruction* size* source* destination*) + (call-with-values + (lambda () (expand-descriptor (car descriptors) environment)) + (lambda (instruction size source destination) + (values (append! instruction instruction*) + (+ size size*) + (if source + (begin + (if source* + (error "Multiple source definitions:" + source source*)) + source) + source*) + (if destination + (begin + (if destination* + (error "Multiple destination definitions:" + destination destination*)) + destination) + destination*)))))) + (values '() 0 #f #f))) (define (collect-word instruction src dst tail) (let ((code @@ -240,33 +287,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA `(,(if (null? code) 'CONS 'CONS-SYNTAX) ,(optimize-group-syntax instruction early-instruction-parsing?) ,code) - code))) - -(define (expand-descriptors descriptors receiver) - (if (null? descriptors) - (receiver '() 0 false false) - (expand-descriptors (cdr descriptors) - (lambda (instruction* size* source* destination*) - (expand-descriptor (car descriptors) - (lambda (instruction size source destination) - (receiver (append! instruction instruction*) - (+ size size*) - (if source - (if source* - (error "Multiple source definitions" - 'EXPAND-DESCRIPTORS) - source) - source*) - (if destination - (if destination* - (error "Multiple destination definitions" - 'EXPAND-DESCRIPTORS) - destination) - destination*)))))))) + code))) ;;;; Hooks for early instruction processing -(define early-instruction-parsing? false) +(define early-instruction-parsing? #f) (define ea-keyword-selector 'EA-KEYWORD) (define ea-categories-selector 'EA-CATEGORIES) (define ea-mode-selector 'EA-MODE) @@ -274,7 +299,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define ea-extension-selector 'EA-EXTENSION) (define (with-normal-selectors handle) - (fluid-let ((early-instruction-parsing? false) + (fluid-let ((early-instruction-parsing? #f) (ea-keyword-selector 'EA-KEYWORD) (ea-categories-selector 'EA-CATEGORIES) (ea-mode-selector 'EA-MODE) @@ -290,39 +315,38 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (ea-register-selector 'EA-REGISTER-EARLY) (ea-extension-selector 'EA-EXTENSION-EARLY)) (handle))) - -(define (expand-descriptor descriptor receiver) + +(define (expand-descriptor descriptor environment) (let ((size (car descriptor)) - (expression (cadr descriptor)) + (expression (close-syntax (cadr descriptor) environment)) (coercion-type - (if (null? (cddr descriptor)) 'UNSIGNED (caddr descriptor)))) + (if (pair? (cddr descriptor)) (caddr descriptor) 'UNSIGNED))) (case coercion-type ((UNSIGNED SIGNED SHIFT-NUMBER QUICK BFWIDTH SCALE-FACTOR) - (receiver `(,(integer-syntaxer expression coercion-type size)) - size false false)) + (values `(,(integer-syntaxer expression coercion-type size)) + size #f #f)) ((SHORT-LABEL) - (receiver `(,(integer-syntaxer - ``(- ,,expression (+ *PC* 2)) - 'SHORT-LABEL - size)) - size false false)) + (values `(,(integer-syntaxer ``(- ,,expression (+ *PC* 2)) + 'SHORT-LABEL + size)) + size #f #f)) ((SOURCE-EA) - (receiver `((,ea-mode-selector ,expression) - (,ea-register-selector ,expression)) - size - `((,ea-extension-selector ,expression) ,(cadddr descriptor)) - false)) + (values `((,ea-mode-selector ,expression) + (,ea-register-selector ,expression)) + size + `((,ea-extension-selector ,expression) ,(cadddr descriptor)) + #f)) ((DESTINATION-EA) - (receiver `((,ea-mode-selector ,expression) - (,ea-register-selector ,expression)) - size - false - `((,ea-extension-selector ,expression) '()))) + (values `((,ea-mode-selector ,expression) + (,ea-register-selector ,expression)) + size + #f + `((,ea-extension-selector ,expression) '()))) ((DESTINATION-EA-REVERSED) - (receiver `((,ea-register-selector ,expression) - (,ea-mode-selector ,expression)) - size - false - `((,ea-extension-selector ,expression) '()))) + (values `((,ea-register-selector ,expression) + (,ea-mode-selector ,expression)) + size + #f + `((,ea-extension-selector ,expression) '()))) (else - (error "EXPAND-DESCRIPTOR: Badly-formed descriptor" descriptor))))) \ No newline at end of file + (error "Badly-formed descriptor:" descriptor))))) \ No newline at end of file -- 2.25.1