From abcff5bed4bc79d03688bccda9424924e46ef9e5 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 13 Feb 2008 14:25:33 +0000 Subject: [PATCH] Rewrite some more variable references as explicit primitive constants. This includes one instance, in MAKE-MACRO-REFERENCE-TRAP-EXPRESSION, that was causing a fatal error. --- v7/src/runtime/advice.scm | 5 +-- v7/src/runtime/sdata.scm | 64 ++++++++++++++++++++++++--------------- v7/src/runtime/unsyn.scm | 4 +-- v7/src/runtime/urtrap.scm | 8 +++-- 4 files changed, 50 insertions(+), 31 deletions(-) diff --git a/v7/src/runtime/advice.scm b/v7/src/runtime/advice.scm index 11cc3b931..16c10c6b6 100644 --- a/v7/src/runtime/advice.scm +++ b/v7/src/runtime/advice.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: advice.scm,v 14.24 2008/01/30 20:02:28 cph Exp $ +$Id: advice.scm,v 14.25 2008/02/13 14:25:30 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -65,7 +65,8 @@ USA. (define (make-advice-hook) ;; This inserts the actual procedure in a constant list. (make-combination - (make-combination car (list (list hook/advised-procedure-wrapper))) + (make-combination (ucode-primitive car) + (list (list hook/advised-procedure-wrapper))) (list (make-the-environment)))) (define (hook/advised-procedure-wrapper environment) diff --git a/v7/src/runtime/sdata.scm b/v7/src/runtime/sdata.scm index 35a41df4c..9da30f33b 100644 --- a/v7/src/runtime/sdata.scm +++ b/v7/src/runtime/sdata.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: sdata.scm,v 14.8 2008/01/30 20:02:35 cph Exp $ +$Id: sdata.scm,v 14.9 2008/02/13 14:25:31 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -31,57 +31,69 @@ USA. (declare (usual-integrations)) (define (&typed-singleton-cons type element) - (system-pair-cons type (unmap-reference-trap element) '())) + ((ucode-primitive system-pair-cons) type (unmap-reference-trap element) '())) (define (&singleton-element singleton) - (map-reference-trap (lambda () (system-pair-car singleton)))) + (map-reference-trap + (lambda () + ((ucode-primitive system-pair-car) singleton)))) (define (&singleton-set-element! singleton new-element) - (system-pair-set-car! singleton (unmap-reference-trap new-element))) + ((ucode-primitive system-pair-set-car!) + singleton + (unmap-reference-trap new-element))) (define (&typed-pair-cons type car cdr) - (system-pair-cons type - (unmap-reference-trap car) - (unmap-reference-trap cdr))) + ((ucode-primitive system-pair-cons) + type + (unmap-reference-trap car) + (unmap-reference-trap cdr))) (define (&pair-car pair) - (map-reference-trap (lambda () (system-pair-car pair)))) + (map-reference-trap (lambda () ((ucode-primitive system-pair-car) pair)))) (define (&pair-set-car! pair new-car) - (system-pair-set-car! pair (unmap-reference-trap new-car))) + ((ucode-primitive system-pair-set-car!) pair (unmap-reference-trap new-car))) (define (&pair-cdr pair) - (map-reference-trap (lambda () (system-pair-cdr pair)))) + (map-reference-trap (lambda () ((ucode-primitive system-pair-cdr) pair)))) (define (&pair-set-cdr! pair new-cdr) - (system-pair-set-cdr! pair (unmap-reference-trap new-cdr))) + ((ucode-primitive system-pair-set-cdr!) pair (unmap-reference-trap new-cdr))) (define (&typed-triple-cons type first second third) (object-new-type type - (hunk3-cons (unmap-reference-trap first) - (unmap-reference-trap second) - (unmap-reference-trap third)))) + ((ucode-primitive hunk3-cons) + (unmap-reference-trap first) + (unmap-reference-trap second) + (unmap-reference-trap third)))) (define (&triple-first triple) - (map-reference-trap (lambda () (system-hunk3-cxr0 triple)))) + (map-reference-trap (lambda () ((ucode-primitive system-hunk3-cxr0) triple)))) (define (&triple-set-first! triple new-first) - (system-hunk3-set-cxr0! triple (unmap-reference-trap new-first))) + ((ucode-primitive system-hunk3-set-cxr0!) + triple + (unmap-reference-trap new-first))) (define (&triple-second triple) - (map-reference-trap (lambda () (system-hunk3-cxr1 triple)))) + (map-reference-trap (lambda () ((ucode-primitive system-hunk3-cxr1) triple)))) (define (&triple-set-second! triple new-second) - (system-hunk3-set-cxr1! triple (unmap-reference-trap new-second))) + ((ucode-primitive system-hunk3-set-cxr1!) + triple + (unmap-reference-trap new-second))) (define (&triple-third triple) - (map-reference-trap (lambda () (system-hunk3-cxr2 triple)))) + (map-reference-trap (lambda () ((ucode-primitive system-hunk3-cxr2) triple)))) (define (&triple-set-third! triple new-third) - (system-hunk3-set-cxr2! triple (unmap-reference-trap new-third))) + ((ucode-primitive system-hunk3-set-cxr2!) + triple + (unmap-reference-trap new-third))) (define (&typed-vector-cons type elements) - (system-list->vector + ((ucode-primitive system-list-to-vector) type (let loop ((elements elements)) (if (null? elements) @@ -90,13 +102,17 @@ USA. (loop (cdr elements))))))) (define (&vector-length vector) - (system-vector-length vector)) + ((ucode-primitive system-vector-size) vector)) (define (&vector-ref vector index) - (map-reference-trap (lambda () (system-vector-ref vector index)))) + (map-reference-trap + (lambda () + ((ucode-primitive system-vector-ref) vector index)))) (define (&subvector->list vector start stop) - (let loop ((sublist (system-subvector->list vector start stop))) + (let loop + ((sublist + ((ucode-primitive system-subvector-to-list) vector start stop))) (if (null? sublist) '() (cons (map-reference-trap (lambda () (car sublist))) diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm index 49c7ed207..a531d95c2 100644 --- a/v7/src/runtime/unsyn.scm +++ b/v7/src/runtime/unsyn.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: unsyn.scm,v 14.35 2008/01/30 20:02:36 cph Exp $ +$Id: unsyn.scm,v 14.36 2008/02/13 14:25:32 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -394,7 +394,7 @@ USA. (cond ((or (not (eq? #t unsyntaxer:macroize?)) (has-substitution? operator)) (ordinary-combination)) - ((and (or (eq? operator cons) + ((and (or (eq? operator (ucode-primitive cons)) (absolute-reference-to? operator 'CONS)) (= (length operands) 2) (delay? (cadr operands)) diff --git a/v7/src/runtime/urtrap.scm b/v7/src/runtime/urtrap.scm index d28356849..2e27aff02 100644 --- a/v7/src/runtime/urtrap.scm +++ b/v7/src/runtime/urtrap.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: urtrap.scm,v 14.20 2008/01/30 20:02:37 cph Exp $ +$Id: urtrap.scm,v 14.21 2008/02/13 14:25:33 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -162,7 +162,8 @@ USA. (define (make-macro-reference-trap-expression transformer) (make-combination primitive-object-set-type (list (ucode-type reference-trap) - (make-combination cons (list 15 transformer))))) + (make-combination (ucode-primitive cons) + (list 15 transformer))))) (define (macro-reference-trap-expression? expression) (and (combination? expression) @@ -173,7 +174,8 @@ USA. (pair? (cdr operands)) (let ((expression (cadr operands))) (and (combination? expression) - (eq? (combination-operator expression) cons) + (eq? (combination-operator expression) + (ucode-primitive cons)) (let ((operands (combination-operands expression))) (and (pair? operands) (eqv? (car operands) 15) -- 2.25.1