From: Chris Hanson Date: Wed, 18 Jan 2017 05:50:21 +0000 (-0800) Subject: Greatly restrict the exports from utabs. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~109 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5e0a7c5a1792b2873b6a977a190c7184cfdd8720;p=mit-scheme.git Greatly restrict the exports from utabs. --- diff --git a/src/compiler/fgopt/order.scm b/src/compiler/fgopt/order.scm index df9497d67..3ffdcfc1c 100644 --- a/src/compiler/fgopt/order.scm +++ b/src/compiler/fgopt/order.scm @@ -238,12 +238,10 @@ USA. (not (procedure-original-rest model)))) (warn "wrong number of arguments" n-supplied - (error-irritant/noise char:newline) - (error-irritant/noise "in call to procedure") + (error-irritant/noise "\nin call to procedure") (procedure-name model) - (error-irritant/noise char:newline) (error-irritant/noise - "minimum/maximum number of arguments:") + "\nminimum/maximum number of arguments:") n-required n-expected)) (- n-expected n-supplied)))) diff --git a/src/edwin/autosv.scm b/src/edwin/autosv.scm index 905fa1c7e..1590a3876 100644 --- a/src/edwin/autosv.scm +++ b/src/edwin/autosv.scm @@ -109,25 +109,18 @@ This file is not the file you visited; that changes only when you save." (lambda () (remove-group-microcode-entry (buffer-group buffer))))) -(define add-group-microcode-entry) -(define remove-group-microcode-entry) -(let ((index (fixed-objects-vector-slot 'EDWIN-AUTO-SAVE))) - (set! add-group-microcode-entry - (lambda (group namestring) - (let ((vector (get-fixed-objects-vector))) - (let ((alist (vector-ref vector index))) - (let ((entry (assq group alist))) - (if entry - (set-cdr! entry namestring) - (vector-set! vector - index - (cons (cons group namestring) alist)))))))) - (set! remove-group-microcode-entry - (lambda (group) - (let ((vector (get-fixed-objects-vector))) - (vector-set! vector - index - (del-assq! group (vector-ref vector index))))))) +(define (add-group-microcode-entry group namestring) + (let ((entry (assq group (fixed-objects-item 'edwin-auto-save)))) + (if entry + (set-cdr! entry namestring) + (update-fixed-objects-item! 'edwin-auto-save + (lambda (alist) + (cons (cons group namestring) alist)))))) + +(define (remove-group-microcode-entry group) + (update-fixed-objects-item! 'edwin-auto-save + (lambda (alist) + (del-assq! group alist)))) (define (delete-auto-save-file! buffer) (and (ref-variable delete-auto-save-files) diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index f16024d6d..fbb564d04 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -119,6 +119,9 @@ USA. define-primitives ucode-primitive ucode-type) + (import (runtime microcode-tables) + fixed-objects-item + update-fixed-objects-item!) (import (runtime port) (make-port make-textual-port) (make-port-type make-textual-port-type) diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm index af7fcaed2..56b65ac96 100644 --- a/src/runtime/arith.scm +++ b/src/runtime/arith.scm @@ -125,27 +125,21 @@ USA. (initialize-microcode-dependencies!) (add-event-receiver! event:after-restore initialize-microcode-dependencies!) (initialize-*maximum-fixnum-radix-powers*!) - (let ((fixed-objects-vector (get-fixed-objects-vector))) - (let ((set-trampoline! - (lambda (slot operator) - (vector-set! fixed-objects-vector - (fixed-objects-vector-slot slot) - operator)))) - (set-trampoline! 'GENERIC-TRAMPOLINE-ZERO? complex:zero?) - (set-trampoline! 'GENERIC-TRAMPOLINE-POSITIVE? complex:positive?) - (set-trampoline! 'GENERIC-TRAMPOLINE-NEGATIVE? complex:negative?) - (set-trampoline! 'GENERIC-TRAMPOLINE-ADD-1 complex:1+) - (set-trampoline! 'GENERIC-TRAMPOLINE-SUBTRACT-1 complex:-1+) - (set-trampoline! 'GENERIC-TRAMPOLINE-EQUAL? complex:=) - (set-trampoline! 'GENERIC-TRAMPOLINE-LESS? complex:<) - (set-trampoline! 'GENERIC-TRAMPOLINE-GREATER? complex:>) - (set-trampoline! 'GENERIC-TRAMPOLINE-ADD complex:+) - (set-trampoline! 'GENERIC-TRAMPOLINE-SUBTRACT complex:-) - (set-trampoline! 'GENERIC-TRAMPOLINE-MULTIPLY complex:*) - (set-trampoline! 'GENERIC-TRAMPOLINE-DIVIDE complex:/) - (set-trampoline! 'GENERIC-TRAMPOLINE-QUOTIENT complex:quotient) - (set-trampoline! 'GENERIC-TRAMPOLINE-REMAINDER complex:remainder) - (set-trampoline! 'GENERIC-TRAMPOLINE-MODULO complex:modulo))) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-ZERO? complex:zero?) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-POSITIVE? complex:positive?) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-NEGATIVE? complex:negative?) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-ADD-1 complex:1+) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-SUBTRACT-1 complex:-1+) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-EQUAL? complex:=) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-LESS? complex:<) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-GREATER? complex:>) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-ADD complex:+) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-SUBTRACT complex:-) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-MULTIPLY complex:*) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-DIVIDE complex:/) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-QUOTIENT complex:quotient) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-REMAINDER complex:remainder) + (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-MODULO complex:modulo) ;; The binary cases for the following operators rely on the fact that the ;; & operators, either interpreted or open-coded by the diff --git a/src/runtime/histry.scm b/src/runtime/histry.scm index 91896fc2b..5daab32c5 100644 --- a/src/runtime/histry.scm +++ b/src/runtime/histry.scm @@ -229,7 +229,6 @@ USA. (define (initialize-package!) (set! the-empty-history - (cons (vector-ref (get-fixed-objects-vector) - (fixed-objects-vector-slot 'DUMMY-HISTORY)) + (cons (fixed-objects-item 'DUMMY-HISTORY) '())) unspecific) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index b2b12caba..aabf22103 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3123,17 +3123,6 @@ USA. (files "utabs") (parent (runtime)) (export () - char:newline - fixed-object/code->name - fixed-object/code-limit - fixed-object/name->code - fixed-objects-item - fixed-objects-vector-slot - get-microcode-version-numbers - get-microcode-version-string - microcode-error/code->name - microcode-error/code-limit - microcode-error/name->code microcode-id/compiled-code-type microcode-id/floating-epsilon microcode-id/floating-mantissa-bits @@ -3145,23 +3134,43 @@ USA. microcode-id/stack-type microcode-id/tty-x-size microcode-id/tty-y-size - microcode-identification-item - microcode-identification-vector-slot - microcode-object/unassigned + microcode-type/code-limit) + (export (runtime) + char:newline + fixed-objects-accessor + fixed-objects-item + fixed-objects-modifier + fixed-objects-updater + get-microcode-version-numbers + microcode-type/code->name + microcode-type/code->names + microcode-type/name->code + set-fixed-objects-item! + update-fixed-objects-item!) + (export (runtime continuation-parser) + microcode-return/code-limit) + (export (runtime garbage-collector) + fixed-objects-vector-slot) + (export (runtime gc-daemons) + fixed-objects-vector-slot) + (export (runtime interrupt-handler) + fixed-objects-vector-slot + microcode-termination/code-limit) + (export (runtime microcode-data) + microcode-error/name->code + microcode-return/code->name + microcode-return/name->code + microcode-termination/name->code) + (export (runtime microcode-errors) + fixed-objects-vector-slot + microcode-error/code->name + microcode-error/code-limit + microcode-error/name->code microcode-return/code->name - microcode-return/code-limit microcode-return/name->code microcode-system-call-error/code->name microcode-system-call-error/name->code - microcode-system-call/code->name - microcode-system-call/name->code - microcode-termination/code->name - microcode-termination/code-limit - microcode-termination/name->code - microcode-type/code->name - microcode-type/code->names - microcode-type/code-limit - microcode-type/name->code) + microcode-system-call/code->name) (export (runtime save/restore) read-microcode-tables!) (initialization (initialize-package!))) diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm index eb5f5e42c..ad80179d6 100644 --- a/src/runtime/sfile.scm +++ b/src/runtime/sfile.scm @@ -202,28 +202,26 @@ USA. (define (allocate-temporary-file pathname) (and (not (file-exists? pathname)) - (let ((objects (get-fixed-objects-vector)) - (slot (fixed-objects-vector-slot 'FILES-TO-DELETE)) + (let ((updater (fixed-objects-updater 'files-to-delete)) (filename (->namestring pathname))) (with-files-to-delete-locked (lambda () (and (file-touch pathname) (begin - (vector-set! objects slot - (cons filename (vector-ref objects slot))) - ((ucode-primitive set-fixed-objects-vector! 1) objects) + (updater + (lambda (filenames) + (cons filename filenames))) #t))))))) (define (deallocate-temporary-file pathname) (delete-file-no-errors pathname) - (let ((objects (get-fixed-objects-vector)) - (slot (fixed-objects-vector-slot 'FILES-TO-DELETE)) + (let ((updater (fixed-objects-updater 'files-to-delete)) (filename (->namestring pathname))) (with-files-to-delete-locked (lambda () - (vector-set! objects slot - (delete! filename (vector-ref objects slot))) - ((ucode-primitive set-fixed-objects-vector! 1) objects))))) + (updater + (lambda (filenames) + (delete! filename filenames))))))) ;;;; Init files diff --git a/src/runtime/uerror.scm b/src/runtime/uerror.scm index 78f73a376..4ddf11f29 100644 --- a/src/runtime/uerror.scm +++ b/src/runtime/uerror.scm @@ -458,19 +458,12 @@ USA. continuation argument))) -(let ((fixed-objects (get-fixed-objects-vector))) - (vector-set! fixed-objects - (fixed-objects-vector-slot 'SYSTEM-ERROR-VECTOR) - error-handler-vector) - (vector-set! fixed-objects - (fixed-objects-vector-slot 'ERROR-PROCEDURE) - (lambda (datum arguments environment) - environment - (apply error (cons* datum arguments)))) - (vector-set! fixed-objects - (fixed-objects-vector-slot 'COMPILER-ERROR-PROCEDURE) - error) - ((ucode-primitive set-fixed-objects-vector!) fixed-objects)) +(set-fixed-objects-item! 'system-error-vector error-handler-vector) +(set-fixed-objects-item! 'error-procedure + (lambda (datum arguments environment) + environment + (apply error (cons* datum arguments)))) +(set-fixed-objects-item! 'compiler-error-procedure error) ;;;; Variable Errors diff --git a/src/runtime/utabs.scm b/src/runtime/utabs.scm index 93837acd9..ac43bc954 100644 --- a/src/runtime/utabs.scm +++ b/src/runtime/utabs.scm @@ -121,10 +121,32 @@ USA. (define (fixed-objects-vector-slot name) (or (fixed-object/name->code name) - (error:bad-range-argument name 'FIXED-OBJECTS-VECTOR-SLOT))) + (error:bad-range-argument name 'fixed-objects-vector-slot))) + +(define (fixed-objects-accessor name) + (let ((index (fixed-objects-vector-slot name))) + (lambda () + (vector-ref (get-fixed-objects-vector) index)))) + +(define (fixed-objects-modifier name) + (let ((index (fixed-objects-vector-slot name))) + (lambda (object) + (vector-set! (get-fixed-objects-vector) index object)))) + +(define (fixed-objects-updater name) + (let ((index (fixed-objects-vector-slot name))) + (lambda (updater) + (let ((v (get-fixed-objects-vector))) + (vector-set! v index (updater (vector-ref v index))))))) (define (fixed-objects-item name) - (vector-ref (get-fixed-objects-vector) (fixed-objects-vector-slot name))) + ((fixed-objects-accessor name))) + +(define (set-fixed-objects-item! name object) + ((fixed-objects-modifier name) object)) + +(define (update-fixed-objects-item! name updater) + ((fixed-objects-updater name) updater)) (define (microcode-object/unassigned) (vector-ref (get-fixed-objects-vector) non-object-slot)) diff --git a/src/sf/gconst.scm b/src/sf/gconst.scm index 6ee3a1fdb..090a4323d 100644 --- a/src/sf/gconst.scm +++ b/src/sf/gconst.scm @@ -33,7 +33,6 @@ USA. '(CHAR-BITS-LIMIT CHAR-CODE-LIMIT CHAR-INTEGER-LIMIT - CHAR:NEWLINE FALSE LAMBDA-TAG:UNNAMED ;needed for cold load SYSTEM-GLOBAL-ENVIRONMENT ;suppresses warnings about (access ...) diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg index cfcd4bc57..f76abb4ba 100644 --- a/src/sf/sf.pkg +++ b/src/sf/sf.pkg @@ -38,7 +38,9 @@ USA. (parent ()) (export () sf:enable-argument-deletion? - sf:enable-constant-folding?)) + sf:enable-constant-folding?) + (import (runtime microcode-tables) + microcode-type/code->name)) (define-package (scode-optimizer global-imports) (files "gimprt") diff --git a/src/sos/sos.pkg b/src/sos/sos.pkg index 170fbcefd..a33043e0e 100644 --- a/src/sos/sos.pkg +++ b/src/sos/sos.pkg @@ -115,6 +115,9 @@ USA. record-class record-type-class subclass?) + (import (runtime microcode-tables) + microcode-type/code->name + microcode-type/name->code) (import (runtime record-slot-access) error:no-such-slot)) diff --git a/src/win32/win32.pkg b/src/win32/win32.pkg index 11531986a..5fca437e7 100644 --- a/src/win32/win32.pkg +++ b/src/win32/win32.pkg @@ -50,6 +50,8 @@ USA. win32-screen-width) (import (runtime) ucode-primitive) + (import (runtime microcode-tables) + fixed-objects-item) (initialization (begin (initialize-protection-list-package!) diff --git a/src/win32/win_ffi.scm b/src/win32/win_ffi.scm index 6724b1f9b..12beb371a 100644 --- a/src/win32/win_ffi.scm +++ b/src/win32/win_ffi.scm @@ -75,7 +75,7 @@ USA. (map (lambda (n) (symbol-append n '-TYPE)) arg-names))) `(LAMBDA (MODULE-ENTRY) - (LET ,(map (lambda (type-name index) + (LET ,(map (lambda (type-name index) `(,type-name (LIST-REF ,(close-syntax 'ARG-TYPES environment) ,(- index 1)))) @@ -116,12 +116,12 @@ USA. (module-entry/machine-address module-entry) (map (lambda (f x) (f x)) arg-types args))) ((access error system-global-environment) - "Wrong arg count for foreign function" + "Wrong arg count for foreign function" name (length args) (list 'requires arg-count))))))))) (parameterize-with-module-entry procedure lib name))) - + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Windows function registry @@ -135,7 +135,7 @@ USA. ;; scheme window. It used the hwnd parameter to find the window-specific ;; version of the wndproc. There is a minor complication: the first time ;; that we know what the window handle is happens during the call to -;; GENERAL-SCHEME-WNDPROC, so we can only associate the handle with +;; GENERAL-SCHEME-WNDPROC, so we can only associate the handle with ;; the window procedure at that time. Further, we do not know what first ;; or last message is -- Various places in the Win32 API Reference imply ;; the first is WM_CREATE or WM_NCCREATE but I have seen the sequence @@ -186,7 +186,7 @@ USA. ;; How do we delete wndprocs from the table? It is not clear what is the very -;; last windows message received by a window. +;; last windows message received by a window. ;; ;; As a temporary measure we check to see if the windows still exist every GC @@ -216,7 +216,7 @@ USA. (set-window-long hwnd GWL_WNDPROC scheme-wndproc) (hash-table/put! wndproc-registry hwnd (subclass-behaviour old-proc)) unspecific)) - + (define wndproc-registry) (define message-polling-thread) @@ -258,13 +258,12 @@ USA. (loop)) (loop)) - ;; install dummy handler and + ;; install dummy handler and (without-interrupts (lambda () - (let ((system-interrupt-vector - (vector-ref (get-fixed-objects-vector) - (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR)))) - (vector-set! system-interrupt-vector 3 ignoring-interrupt-handler)))) + (vector-set! (fixed-objects-item 'system-interrupt-vector) + 3 + ignoring-interrupt-handler))) (set! message-polling-thread (create-thread #f thunk))) ; @@ -340,15 +339,15 @@ USA. ;;(define get-last-error ;; (make-windows-procedure kernel32.dll "GetLastError" int-result)) -;; +;; ;;(define set-last-error ;; (make-windows-procedure kernel32.dll "SetLastError" void-result int-arg)) - + (define close-window) (define create-round-rect-rgn) (define create-window-ex) (define dispatch-message) -(define get-window-long) +(define get-window-long) (define get-window-text) (define is-iconic?) (define is-window?) @@ -356,12 +355,12 @@ USA. (define message-box) (define message-box-ex) (define peek-message) -(define pt-in-region) +(define pt-in-region) (define set-window-long) (define set-window-text) (define sleep) (define translate-message) -(define unregister-class) +(define unregister-class) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -423,15 +422,15 @@ USA. (set! unregister-class (windows-procedure (unregister-class (name string) (instance hinstance)) bool user32.dll "UnregisterClassA")) - + (set! get-window-long (windows-procedure (get-window-long (hwnd hwnd) (index int)) long user32.dll "GetWindowLongA")) - + (set! set-window-long (windows-procedure (set-window-long (hwnd hwnd) (index int) (value long)) long user32.dll "SetWindowLongA")) - + (set! message-box (windows-procedure (message-box (owner hwnd) (text string ) (title string) (style int)) @@ -467,7 +466,7 @@ USA. ((make-primitive-procedure 'set-general-scheme-wndproc) general-scheme-wndproc)) - + (define (initialize-package!) ;; Install GENERAL-SCHEME-WNDPROC ;; (initialize-general-scheme-wndproc!)