(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))))
(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))))
\f
(define (delete-auto-save-file! buffer)
(and (ref-variable delete-auto-save-files)
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)
(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)
\f
;; The binary cases for the following operators rely on the fact that the
;; &<mumble> operators, either interpreted or open-coded by the
(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
(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
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!)))
(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
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)
\f
;;;; Variable Errors
(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))
'(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 ...)
(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")
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))
win32-screen-width)
(import (runtime)
ucode-primitive)
+ (import (runtime microcode-tables)
+ fixed-objects-item)
(initialization
(begin
(initialize-protection-list-package!)
(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))))
(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
;; 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
;; 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
(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)
(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)))
;
;;(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?)
(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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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))
((make-primitive-procedure 'set-general-scheme-wndproc)
general-scheme-wndproc))
-
+
(define (initialize-package!)
;; Install GENERAL-SCHEME-WNDPROC
;; (initialize-general-scheme-wndproc!)
projects / mit-scheme.git / commitdiff