From: Chris Hanson Date: Sun, 27 Sep 2009 10:36:24 +0000 (-0700) Subject: Fix cold-load errors. X-Git-Tag: 20100708-Gtk~306 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=512e912bf511e2e6ecc608ee3a58e01335ebc56a;p=mit-scheme.git Fix cold-load errors. --- diff --git a/src/runtime/make.scm b/src/runtime/make.scm index f2f773d33..310737daa 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -174,7 +174,9 @@ USA. (and package (let ((env (package/environment package))) (if (not procedure-name) - (lambda () ((access run-boot-inits! boot-defs) env)) + (if (lexical-unreferenceable? env 'INITIALIZE-PACKAGE!) + (lambda () ((access run-boot-inits! boot-defs) env)) + (lexical-reference env 'INITIALIZE-PACKAGE!)) (and (not (lexical-unreferenceable? env procedure-name)) (lexical-reference env procedure-name)))))) => (lambda (procedure) @@ -205,8 +207,12 @@ USA. (let ((spec (car specs))) (if (or (not (pair? spec)) (symbol? (car spec))) - (package-initialize spec 'INITIALIZE-PACKAGE! #f) - (package-initialize (car spec) (cadr spec) (caddr spec))) + (package-initialize spec #f #t) + (package-initialize (car spec) + (cadr spec) + (if (pair? (cddr spec)) + (caddr spec) + #t))) (loop (cdr specs)))))) (define (remember-to-purify purify? filename value) @@ -375,21 +381,21 @@ USA. (eval (file->object (car (car files)) #t #t) (package-reference (cdr (car files)))))))) (load-files files1) - (package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE! #t) - (package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE! #t) - (package-initialize '(RUNTIME RANDOM-NUMBER) 'INITIALIZE-PACKAGE! #t) + (package-initialize '(RUNTIME GC-DAEMONS) #f #t) + (package-initialize '(RUNTIME GARBAGE-COLLECTOR) #f #t) + (package-initialize '(RUNTIME RANDOM-NUMBER) #f #t) (package-initialize '(RUNTIME GENERIC-PROCEDURE) 'INITIALIZE-TAG-CONSTANTS! #t) - (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! #t) + (package-initialize '(RUNTIME POPULATION) #f #t) (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t) (load-files files2) - (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! #t) - (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! #t) - (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! #t) + (package-initialize '(RUNTIME 1D-PROPERTY) #f #t) + (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) #f #t) + (package-initialize '(RUNTIME GLOBAL-DATABASE) #f #t) (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! #t) (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t) - (package-initialize '(RUNTIME GC-FINALIZER) 'INITIALIZE-PACKAGE! #t) - (package-initialize '(RUNTIME STRING) 'INITIALIZE-PACKAGE! #t) + (package-initialize '(RUNTIME GC-FINALIZER) #f #t) + (package-initialize '(RUNTIME STRING) #f #t) (set! boot-defs (package/environment (name->package '(RUNTIME BOOT-DEFINITIONS)))) @@ -422,16 +428,16 @@ USA. (package-initialization-sequence '( ;; Microcode interface - ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES! #t) + ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES!) (RUNTIME STATE-SPACE) (RUNTIME APPLY) (RUNTIME HASH) ; First GC daemon! (RUNTIME PRIMITIVE-IO) (RUNTIME SYSTEM-CLOCK) - ((RUNTIME GC-FINALIZER) INITIALIZE-EVENTS! #t) + ((RUNTIME GC-FINALIZER) INITIALIZE-EVENTS!) ;; Basic data structures (RUNTIME NUMBER) - ((RUNTIME NUMBER) INITIALIZE-DRAGON4! #t) + ((RUNTIME NUMBER) INITIALIZE-DRAGON4!) (RUNTIME MISCELLANEOUS-GLOBAL) (RUNTIME CHARACTER) (RUNTIME CHARACTER-SET) @@ -439,7 +445,7 @@ USA. (RUNTIME STREAM) (RUNTIME 2D-PROPERTY) (RUNTIME HASH-TABLE) - ((RUNTIME REGULAR-SEXPRESSION) #f #f) + (RUNTIME REGULAR-SEXPRESSION) ;; Microcode data structures (RUNTIME HISTORY) (RUNTIME LAMBDA-ABSTRACTION) @@ -449,23 +455,24 @@ USA. (RUNTIME CONTINUATION-PARSER) (RUNTIME PROGRAM-COPIER) ;; Generic Procedures - ((RUNTIME GENERIC-PROCEDURE EQHT) INITIALIZE-ADDRESS-HASHING! #t) - ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-GENERIC-PROCEDURES! #t) - ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-MULTIPLEXER! #t) - ((RUNTIME TAGGED-VECTOR) INITIALIZE-TAGGED-VECTOR! #t) - ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-RECORD-SLOT-ACCESS! #t) - ((RUNTIME RECORD) INITIALIZE-RECORD-PROCEDURES! #t) - ((PACKAGE) FINALIZE-PACKAGE-RECORD-TYPE! #t) - ((RUNTIME RANDOM-NUMBER) FINALIZE-RANDOM-STATE-TYPE! #t) + ((RUNTIME GENERIC-PROCEDURE EQHT) INITIALIZE-ADDRESS-HASHING!) + ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-GENERIC-PROCEDURES!) + ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-MULTIPLEXER!) + ((RUNTIME TAGGED-VECTOR) INITIALIZE-TAGGED-VECTOR!) + ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-RECORD-SLOT-ACCESS!) + ((RUNTIME RECORD) INITIALIZE-RECORD-PROCEDURES!) + ((PACKAGE) FINALIZE-PACKAGE-RECORD-TYPE!) + ((RUNTIME RANDOM-NUMBER) FINALIZE-RANDOM-STATE-TYPE!) ;; Condition System (RUNTIME ERROR-HANDLER) (RUNTIME MICROCODE-ERRORS) - ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS! #t) - ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS! #t) - ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-CONDITIONS! #t) - ((RUNTIME STREAM) INITIALIZE-CONDITIONS! #t) + ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS!) + ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS!) + ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-CONDITIONS!) + ((RUNTIME STREAM) INITIALIZE-CONDITIONS!) + ((RUNTIME REGULAR-SEXPRESSION) INITIALIZE-CONDITIONS!) ;; System dependent stuff - ((RUNTIME OS-PRIMITIVES) INITIALIZE-SYSTEM-PRIMITIVES! #t) + ((RUNTIME OS-PRIMITIVES) INITIALIZE-SYSTEM-PRIMITIVES!) ;; Threads (RUNTIME THREAD) ;; I/O @@ -489,7 +496,7 @@ USA. ;; Syntax (RUNTIME NUMBER-PARSER) (RUNTIME PARSER) - ((RUNTIME PATHNAME) INITIALIZE-PARSER-METHOD! #t) + ((RUNTIME PATHNAME) INITIALIZE-PARSER-METHOD!) (RUNTIME UNPARSER) (RUNTIME UNSYNTAXER) (RUNTIME PRETTY-PRINTER) @@ -513,19 +520,19 @@ USA. ;; Graphics. The last type initialized is the default for ;; MAKE-GRAPHICS-DEVICE, only the types that are valid for the ;; operating system are actually loaded and initialized. - (RUNTIME STARBASE-GRAPHICS) + ((RUNTIME STARBASE-GRAPHICS) #f #f) (RUNTIME X-GRAPHICS) - (RUNTIME OS2-GRAPHICS) + ((RUNTIME OS2-GRAPHICS) #f #f) ;; Emacs -- last because it installs hooks everywhere which must be initted. (RUNTIME EMACS-INTERFACE) ;; More debugging ((RUNTIME CONTINUATION-PARSER) INITIALIZE-SPECIAL-FRAMES! #f) (RUNTIME URI) (RUNTIME RFC2822-HEADERS) - ((RUNTIME HTTP-SYNTAX) #f #f) + (RUNTIME HTTP-SYNTAX) (RUNTIME HTTP-CLIENT) (RUNTIME HTML-FORM-CODEC) - (RUNTIME WIN32-REGISTRY))) + ((RUNTIME WIN32-REGISTRY) #f #f))) (let ((obj (file->object "site" #t #f))) (if obj diff --git a/src/runtime/regsexp.scm b/src/runtime/regsexp.scm index ddac4b36e..7f0a3394d 100644 --- a/src/runtime/regsexp.scm +++ b/src/runtime/regsexp.scm @@ -98,18 +98,21 @@ USA. (error "Ill-formed regsexp group key:" key)) key) -(define condition-type:compile-regsexp - (make-condition-type 'COMPILE-REGSEXP condition-type:error - '(PATTERN CAUSE) - (lambda (condition port) - (write (access-condition condition 'PATTERN) port) - (write-string ": " port) - (write-condition-report (access-condition condition 'CAUSE) port)))) - -(define signal-compile-error - (condition-signaller condition-type:compile-regsexp - '(PATTERN CAUSE) - standard-error-handler)) +(define condition-type:compile-regsexp) +(define signal-compile-error) +(define (initialize-conditions!) + (set! condition-type:compile-regsexp + (make-condition-type 'COMPILE-REGSEXP condition-type:error + '(PATTERN CAUSE) + (lambda (condition port) + (write (access-condition condition 'PATTERN) port) + (write-string ": " port) + (write-condition-report (access-condition condition 'CAUSE) port)))) + (set! signal-compile-error + (condition-signaller condition-type:compile-regsexp + '(PATTERN CAUSE) + standard-error-handler)) + unspecific) ;;;; Compiler rules