#| -*-Scheme-*-
-$Id: asmmac.scm,v 1.10 2001/12/23 17:20:57 cph Exp $
+$Id: asmmac.scm,v 1.11 2002/02/07 05:57:44 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
(declare (usual-integrations))
\f
(define-syntax define-instruction
- (non-hygienic-macro-transformer
- (lambda (keyword . rules)
- `(ADD-INSTRUCTION!
- ',keyword
- ,(compile-database rules
- (lambda (pattern actions)
- pattern
- (if (not (pair? actions))
- (error "DEFINE-INSTRUCTION: Too few forms."))
- (parse-instruction (car actions) (cdr actions) #f)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(SYMBOL * DATUM) (cdr form))
+ `(ADD-INSTRUCTION!
+ ',(cadr form)
+ ,(compile-database (cddr form)
+ (lambda (pattern actions)
+ pattern
+ (if (not (pair? actions))
+ (error "DEFINE-INSTRUCTION: Too few forms."))
+ (parse-instruction (car actions) (cdr actions) #f))))
+ (ill-formed-syntax form)))))
(define (compile-database cases procedure)
`(LIST
#| -*-Scheme-*-
-$Id: lapgn3.scm,v 4.14 2001/12/23 17:20:57 cph Exp $
+$Id: lapgn3.scm,v 4.15 2002/02/07 05:57:54 cph Exp $
-Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1987-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
(let ((label
(string->uninterned-symbol
(string-append prefix (number->string *next-constant*)))))
- (set! *next-constant* (1+ *next-constant*))
+ (set! *next-constant* (+ *next-constant* 1))
label))
(define (allocate-constant-label)
(allocate-named-label "CONSTANT-"))
(define (warning-assoc obj pairs)
- (define (local-eqv? obj1 obj2)
- (or (eqv? obj1 obj2)
- (and (string? obj1)
- (string? obj2)
- (zero? (string-length obj1))
- (zero? (string-length obj2)))))
-
(let ((pair (assoc obj pairs)))
(if (and compiler:coalescing-constant-warnings?
(pair? pair)
- (not (local-eqv? obj (car pair))))
+ (not (let ((obj* (car pair)))
+ (or (eqv? obj obj*)
+ (and (string? obj)
+ (string? obj*)
+ (fix:= 0 (string-length obj))
+ (fix:= 0 (string-length obj*)))))))
(warn "Coalescing two copies of constant object" obj))
pair))
-(define-integrable (object->label find read write allocate-label)
- (lambda (object)
- (let ((entry (find object (read))))
- (if entry
- (cdr entry)
- (let ((label (allocate-label object)))
- (write (cons (cons object label)
- (read)))
- label)))))
+(define ((object->label find read write allocate-label) object)
+ (let ((entry (find object (read))))
+ (if entry
+ (cdr entry)
+ (let ((label (allocate-label object)))
+ (write (cons (cons object label) (read)))
+ label))))
(let-syntax
((->label
- (non-hygienic-macro-transformer
- (lambda (find var #!optional suffix)
- `(object->label ,find
- (lambda () ,var)
- (lambda (new)
- (declare (integrate new))
- (set! ,var new))
- ,(if (default-object? suffix)
- `(lambda (object)
- object ; ignore
- (allocate-named-label "OBJECT-"))
- `(lambda (object)
- (allocate-named-label
- (string-append (symbol->string object)
- ,suffix)))))))))
+ (sc-macro-transformer
+ (let ((pattern `(EXPRESSION IDENTIFIER ? ,string?)))
+ (lambda (form environment)
+ (if (syntax-match? pattern (cdr form))
+ (let ((find (close-syntax (cadr form) environment))
+ (var (close-syntax (caddr form) environment))
+ (suffix (and (pair? (cdddr form)) (cadddr form))))
+ `(OBJECT->LABEL ,find
+ (LAMBDA () ,var)
+ (LAMBDA (NEW)
+ (DECLARE (INTEGRATE NEW))
+ (SET! ,var NEW))
+ ,(if suffix
+ `(LAMBDA (OBJECT)
+ (ALLOCATE-NAMED-LABEL
+ (STRING-APPEND
+ (SYMBOL->STRING OBJECT)
+ ,suffix)))
+ `(LAMBDA (OBJECT)
+ OBJECT ; ignore
+ (ALLOCATE-NAMED-LABEL "OBJECT-")))))
+ (ill-formed-syntax form)))))))
+
(define constant->label
(->label warning-assoc *interned-constants*))
(define free-static-label
(->label assq *interned-static-variables* "-HOME-"))
-;; End of let-syntax
)
\f
;; These are different because different uuo-links are used for different
#| -*-Scheme-*-
-$Id: crsend.scm,v 1.12 2001/12/23 17:20:57 cph Exp $
+$Id: crsend.scm,v 1.13 2002/02/07 05:58:04 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
(declare (usual-integrations))
\f
+(define-syntax ucode-primitive
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply make-primitive-procedure (cdr form)))))
+
+(define-syntax ucode-type
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply microcode-type (cdr form)))))
+
(define (cross-compile-bin-file-end input-string #!optional output-string)
(compiler-pathnames input-string
(and (not (default-object? output-string)) output-string)
label
(with-absolutely-no-interrupts
(lambda ()
- (let-syntax ((ucode-primitive
- (non-hygienic-macro-transformer
- (lambda (name)
- (make-primitive-procedure name))))
- (ucode-type
- (non-hygienic-macro-transformer
- (lambda (name)
- (microcode-type name)))))
- ((ucode-primitive PRIMITIVE-OBJECT-SET-TYPE)
- (ucode-type COMPILED-ENTRY)
- (make-non-pointer-object
- (+ (cdr (or (assq label label-bindings)
- (error "Missing entry point" label)))
- (object-datum code-vector)))))))))
+ ((ucode-primitive primitive-object-set-type)
+ (ucode-type compiled-entry)
+ (make-non-pointer-object
+ (+ (cdr (or (assq label label-bindings)
+ (error "Missing entry point" label)))
+ (object-datum code-vector))))))))
(cc-vector/entry-points cc-vector)))))
(let ((label->expression
(lambda (label)
expression))))
\f
(define (cross-link/finish-assembly code-block objects scheme-object-width)
- (let-syntax ((ucode-primitive
- (non-hygienic-macro-transformer
- (lambda (name)
- (make-primitive-procedure name))))
- (ucode-type
- (non-hygienic-macro-transformer
- (lambda (name)
- (microcode-type name)))))
- (let* ((bl (quotient (bit-string-length code-block)
- scheme-object-width))
- (non-pointer-length
- ((ucode-primitive make-non-pointer-object) bl))
- (output-block (make-vector (1+ (+ (length objects) bl)))))
- (with-absolutely-no-interrupts
- (lambda ()
- (vector-set! output-block 0
- ((ucode-primitive primitive-object-set-type)
- (ucode-type manifest-nm-vector)
- non-pointer-length))))
- (write-bits! output-block
- ;; After header just inserted.
- (* scheme-object-width 2)
- code-block)
- (insert-objects! output-block objects (1+ bl))
- (object-new-type (ucode-type compiled-code-block)
- output-block))))
+ (let* ((bl (quotient (bit-string-length code-block)
+ scheme-object-width))
+ (non-pointer-length
+ ((ucode-primitive make-non-pointer-object) bl))
+ (output-block (make-vector (1+ (+ (length objects) bl)))))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (vector-set! output-block 0
+ ((ucode-primitive primitive-object-set-type)
+ (ucode-type manifest-nm-vector)
+ non-pointer-length))))
+ (write-bits! output-block
+ ;; After header just inserted.
+ (* scheme-object-width 2)
+ code-block)
+ (insert-objects! output-block objects (1+ bl))
+ (object-new-type (ucode-type compiled-code-block)
+ output-block)))
(define (insert-objects! v objects where)
(cond ((not (null? objects))
#| -*-Scheme-*-
-$Id: lvalue.scm,v 4.24 2001/12/23 17:20:57 cph Exp $
+$Id: lvalue.scm,v 4.25 2002/02/07 05:58:14 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
(let-syntax
((define-named-variable
- (non-hygienic-macro-transformer
- (lambda (name)
- (let ((symbol
- (intern (string-append "#[" (symbol->string name) "]"))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let* ((name (cadr form))
+ (symbol
+ (intern (string-append "#[" (symbol->string name) "]"))))
`(BEGIN (DEFINE-INTEGRABLE
(,(symbol-append 'MAKE- name '-VARIABLE) BLOCK)
(MAKE-VARIABLE BLOCK ',symbol))
projects / mit-scheme.git / commitdiff