#| -*-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
'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))))))
\f
-(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))))
`(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)))))
\f
;;;; 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)))))
\f
;;;; 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
\f
;;;; 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
`(,(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)))
\f
;;;; 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)
(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)
(ea-register-selector 'EA-REGISTER-EARLY)
(ea-extension-selector 'EA-EXTENSION-EARLY))
(handle)))
-\f
-(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
projects / mit-scheme.git / commitdiff