From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Tue, 12 Apr 1988 15:01:28 +0000 (+0000)
Subject: Remove with-threaded-continuation and add copy-program.
X-Git-Tag: 20090517-FFI~12834
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d98c0dde4d70cb7185048f6c5a05375f21d43dc0;p=mit-scheme.git

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

diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm
index 23ac33ec3..6969d70e2 100644
--- 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.
 
 ;;;; 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)))
+
+;;; 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 470e32bf5..0f4702d29 100644
--- 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?