Remove with-threaded-continuation and add copy-program.

diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm
index 23ac33ec389ef3f6aa1b9f22f08157f0e0b8780d..6969d70e2e26cfd7256ef198a050b2a28147c70c 100644 (file)
--- a/v7/src/runtime/boot.scm
+++ b/v7/src/runtime/boot.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 13.44 1987/10/09 17:13:14 jinx Rel $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 13.45 1988/04/12 14:59:27 jinx Rel $
 ;;;
-;;;    Copyright (c) 1987 Massachusetts Institute of Technology
+;;;    Copyright (c) 1988 Massachusetts Institute of Technology
 ;;;
 ;;;    This material was developed by the Scheme project at the
 ;;;    Massachusetts Institute of Technology, Department of
@@ -39,10 +39,14 @@
 
 ;;;; Boot Utilities
 
-(declare (usual-integrations))
+(declare (usual-integrations)
+        (integrate-primitive-procedures
+         compiled-code-address->block
+         compiled-code-address->offset
+         primitive-object-set-type))
 
 ;;; The utilities in this file are the first thing loaded into the
-;;; world after the type tables.  They can't depend on anything else
+;;; world after the type tables.  They shouldn't depend on anything else
 ;;; except those tables.
 \f
 ;;;; Primitive Operators
@@ -54,17 +58,14 @@
                           `(DEFINE ,name ,(make-primitive-procedure name)))
                         names)))))
   (define-global-primitives
-   SCODE-EVAL FORCE WITH-THREADED-CONTINUATION
+   SCODE-EVAL FORCE
    SET-INTERRUPT-ENABLES! WITH-INTERRUPTS-REDUCED
    WITH-INTERRUPT-MASK
    GET-FIXED-OBJECTS-VECTOR WITH-HISTORY-DISABLED
    PRIMITIVE-PROCEDURE-ARITY NOT FALSE?
-   ;; UNSNAP-LINKS!
-
    ;; Environment
    LEXICAL-REFERENCE LEXICAL-ASSIGNMENT LOCAL-ASSIGNMENT
    LEXICAL-UNASSIGNED? LEXICAL-UNBOUND? LEXICAL-UNREFERENCEABLE?
-
    ;; Pointers
    EQ?
    PRIMITIVE-SET-TYPE MAKE-NON-POINTER-OBJECT
@@ -101,13 +102,14 @@
 (define false #F)
 (define true #T)
 
-(define (null-procedure . args) '())
-(define (false-procedure . args) #F)
-(define (true-procedure . args) #T)
+(define (null-procedure . args) args '()) ; args ignored
+(define (false-procedure . args) args #F) ; args ignored
+(define (true-procedure . args) args #T) ; args ignored
 
 (define (without-interrupts thunk)
   (with-interrupts-reduced interrupt-mask-gc-ok
     (lambda (old-mask)
+      old-mask ;; ignored
       (thunk))))
 
 (define apply
@@ -138,4 +140,25 @@
 
 (define (boolean? object)
   (or (eq? object #F)
-      (eq? object #T)))
\ No newline at end of file
+      (eq? object #T)))
+\f
+;;; This won't work until vector is loaded, but it has no better place to go.
+
+(let-syntax ((ucode-type (macro (name) (microcode-type name))))
+
+(define (copy-program exp)
+  (if (not (primitive-type? (ucode-type COMPILED-ENTRY) exp))
+      (error "copy-program: Can only copy compiled programs" exp))
+  (let ((v (vector-copy
+           (primitive-set-type
+            (ucode-type VECTOR)
+            (compiled-code-address->block exp)))))
+    (with-interrupt-mask
+     interrupt-mask-none
+     (lambda (old)
+       old ;; ignored
+       (primitive-object-set-type
+       (ucode-type COMPILED-ENTRY)
+       (+ (compiled-code-address->offset exp) (primitive-datum v)))))))
+
+) ;; End of let-syntax
\ No newline at end of file

diff --git a/v7/src/sf/gconst.scm b/v7/src/sf/gconst.scm
index 470e32bf5d6982254841c56cc3d33bb412a515cf..0f4702d29d2eac4f7200f1ad852e8747b24b1df8 100644 (file)
--- a/v7/src/sf/gconst.scm
+++ b/v7/src/sf/gconst.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/gconst.scm,v 3.6 1988/03/22 17:37:01 jrm Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/gconst.scm,v 3.7 1988/04/12 15:01:28 jinx Rel $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -43,7 +43,7 @@ MIT in each case. |#
 (define global-constant-objects
   '(TRUE FALSE SYSTEM-GLOBAL-ENVIRONMENT
     
-    SCODE-EVAL FORCE WITH-THREADED-CONTINUATION
+    SCODE-EVAL FORCE
     SET-INTERRUPT-ENABLES! WITH-INTERRUPT-MASK WITH-INTERRUPTS-REDUCED
     GET-FIXED-OBJECTS-VECTOR WITH-HISTORY-DISABLED
     PRIMITIVE-PROCEDURE-ARITY NOT FALSE?