From: Chris Hanson Date: Thu, 7 Feb 2002 05:58:14 +0000 (+0000) Subject: Eliminate non-hygienic macros. X-Git-Tag: 20090517-FFI~2269 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=174fb56d0e163c8467485428c3cac572c49b90d2;p=mit-scheme.git Eliminate non-hygienic macros. --- diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm index 2668e9445..84175aa7b 100644 --- a/v7/src/compiler/back/asmmac.scm +++ b/v7/src/compiler/back/asmmac.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -25,16 +25,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) (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 diff --git a/v7/src/compiler/back/lapgn3.scm b/v7/src/compiler/back/lapgn3.scm index 6c4a29878..5e51e7746 100644 --- a/v7/src/compiler/back/lapgn3.scm +++ b/v7/src/compiler/back/lapgn3.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -39,54 +39,58 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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*)) @@ -99,7 +103,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define free-static-label (->label assq *interned-static-variables* "-HOME-")) -;; End of let-syntax ) ;; These are different because different uuo-links are used for different diff --git a/v7/src/compiler/base/crsend.scm b/v7/src/compiler/base/crsend.scm index 5d17fb7d4..fa44299fb 100644 --- a/v7/src/compiler/base/crsend.scm +++ b/v7/src/compiler/base/crsend.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -26,6 +26,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) +(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) @@ -118,20 +130,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 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) @@ -145,32 +149,24 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA expression)))) (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)) diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index cb620507f..8b27c9d8e 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -103,10 +103,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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))