Also change their implementation to use define-print-method.
;; Propagate this downward at construction time
;; to avoid having to crawl upward at use time.
(and parent (vector-tag-noop parent)))))
- (unparser/set-tagged-vector-method! tag tagged-vector/unparse)
+ (define-print-method (lambda (object)
+ (and (vector? object)
+ (fix:> (vector-length object) 0)
+ (eq? tag (vector-ref object 0))))
+ (lambda (vector port)
+ (parameterize* (list (cons param:printer-radix 16))
+ (lambda ()
+ ((tagged-vector/unparser vector) vector port)))))
tag))))
(define (define-vector-tag-unparser tag unparser)
((tagged-vector? object)
(vector-tag-description (tagged-vector/tag object)))
(else
- (error "Not a tagged vector" object))))
-
-(define (tagged-vector/unparse state vector)
- (parameterize* (list (cons param:printer-radix 16))
- (lambda ()
- ((tagged-vector/unparser vector) state vector))))
+ (error "Not a tagged vector" object))))
\ No newline at end of file
;;;; Inferiors
(define %inferior-tag
- "inferior")
+ '|#[(edwin window) inferior]|)
+
+(define (%inferior? object)
+ (and (vector? object)
+ (fix:= 5 (vector-length object))
+ (eq? %inferior-tag (vector-ref object 0))))
(define-integrable (%make-inferior window x-start y-start redisplay-flags)
(vector %inferior-tag window x-start y-start redisplay-flags))
(define-integrable (set-inferior-redisplay-flags! inferior redisplay-flags)
(vector-set! inferior 4 redisplay-flags))
-(unparser/set-tagged-vector-method! %inferior-tag
- (bracketed-print-method 'INFERIOR
+(define-print-method %inferior?
+ (bracketed-print-method 'inferior
(lambda (inferior port)
(write-string " " port)
(write (inferior-window inferior) port)
(string-append (print-device (%pathname-device pathname))
(print-directory (%pathname-directory pathname))
(print-name (%pathname-name pathname)
- (%pathname-type pathname))))
+ (%pathname-type pathname))))
(define (print-device device)
(if (or (not device) (eq? device 'unspecific))
;;; package: (runtime global-database)
(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (set! event:after-restore (make-event-distributor))
- (set! event:after-restart (make-event-distributor))
- (set! event:before-exit (make-event-distributor))
- (set! tagged-pair-methods (make-1d-table))
- (set! tagged-vector-methods (make-1d-table))
- (set! named-structure-descriptions (make-1d-table))
- unspecific)
-(define event:after-restore)
-(define event:after-restart)
-(define event:before-exit)
-(define tagged-pair-methods)
-(define tagged-vector-methods)
-(define named-structure-descriptions)
-
-(define (unparser/tagged-pair-method tag)
- (1d-table/get tagged-pair-methods tag #f))
+(define-deferred event:after-restore (make-event-distributor))
+(define-deferred event:after-restart (make-event-distributor))
+(define-deferred event:before-exit (make-event-distributor))
+(define-deferred named-structure-descriptions (make-1d-table))
(define (unparser/set-tagged-pair-method! tag method)
- (1d-table/put! tagged-pair-methods tag method))
-
-(define (unparser/tagged-vector-method tag)
- (1d-table/get tagged-vector-methods tag #f))
+ (define-print-method (lambda (object)
+ (and (pair? object)
+ (eq? tag (car object))))
+ method))
(define (unparser/set-tagged-vector-method! tag method)
- (1d-table/put! tagged-vector-methods tag method))
+ (define-print-method (lambda (object)
+ (and (vector? object)
+ (fix:> (vector-length object) 0)
+ (eq? tag (vector-ref object 0))))
+ method))
(define (named-structure/get-tag-description tag)
(1d-table/get named-structure-descriptions tag #f))
(define (named-structure/set-tag-description! tag description)
- (1d-table/put! named-structure-descriptions tag description))
-
-;;; Support for old-style methods
-
-(define (add-unparser-special-pair! tag method)
- (unparser/set-tagged-pair-method! tag (convert-old-method method)))
-
-(define (add-unparser-special-object! tag method)
- (unparser/set-tagged-vector-method! tag (convert-old-method method)))
-
-(define (unparse-with-brackets thunk)
- (write-string "#[")
- (thunk)
- (write-char #\]))
-
-(define (convert-old-method method)
- (lambda (state object)
- (parameterize* (list (cons current-output-port (unparser-state/port state)))
- (lambda ()
- (method object)))))
\ No newline at end of file
+ (1d-table/put! named-structure-descriptions tag description))
\ No newline at end of file
(package-initialize '(runtime thread) 'initialize-low! #t) ;First 1d-table.
(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) #f #t)
;; Load everything else.
;;; A population is a weak collection of objects. A serial
;;; population is a population with a mutex to serialize its operations.
-(define (initialize-package!)
- (set! population-of-populations (list population-tag (make-thread-mutex)))
- (add-secondary-gc-daemon!/unsafe clean-all-populations!))
+(define-deferred population-of-populations
+ (list population-tag (make-thread-mutex)))
-(define (initialize-unparser!)
- (unparser/set-tagged-pair-method! population-tag
- (standard-print-method 'population)))
+(add-boot-init!
+ (lambda ()
+ (add-secondary-gc-daemon!/unsafe clean-all-populations!)))
-(define bogus-false '(bogus-false))
-(define population-tag '(population))
+(define-integrable population-tag
+ '|#[population]|)
+
+(define-integrable bogus-false
+ '|#[population false]|)
(define-integrable (canonicalize object)
(if (eq? object false) bogus-false object))
(define (clean-all-populations!)
(clean-population! population-of-populations)
(map-over-population! population-of-populations clean-population!))
-
-(define population-of-populations)
\f
(define (make-population)
(let ((population (list population-tag #f)))
(and (pair? object)
(eq? (car object) population-tag)))
+(define-print-method population?
+ (standard-print-method 'population))
+
(define-guarantee population "population")
(define (add-to-population! population object)
(if (string? name)
(*print-string name context*)
(print-object name context*))
- (*print-char #\space context*)
+ (*print-char #\space context*)
(*print-hash object context*)
(cond (procedure
(procedure context*))
(declare (usual-integrations))
\f
-(define (initialize-package!)
- (set! population-of-1d-tables (make-serial-population/unsafe))
- (add-secondary-gc-daemon!/unsafe clean-1d-tables!))
+(define-deferred population-of-1d-tables
+ (make-serial-population/unsafe))
-(define (initialize-unparser!)
- (unparser/set-tagged-pair-method! 1d-table-tag
- (standard-print-method '1d-table)))
-
-(define population-of-1d-tables)
+(add-boot-init!
+ (lambda ()
+ (add-secondary-gc-daemon!/unsafe clean-1d-tables!)))
(define (clean-1d-tables!)
(for-each-inhabitant population-of-1d-tables 1d-table/clean!))
(and (pair? object)
(eq? (car object) 1d-table-tag)))
-(define 1d-table-tag
- "1D table")
+(define-integrable 1d-table-tag
+ '|#[1D table]|)
+
+(define-integrable false-key
+ '|#[1D table false]|)
-(define false-key
- "false key")
+(define-print-method 1d-table?
+ (standard-print-method '1d-table))
(define-integrable (weak-cons car cdr)
(system-pair-cons (ucode-type weak-cons) car cdr))
(and (vector? object)
(fix:= (vector-length object) 4)
(eq? (vector-ref object 0) random-state-tag)))
+(register-predicate! random-state? 'random-state '<= vector?)
(define-integrable random-state-tag
'|#[(runtime random-number)random-state]|)
+(define-print-method random-state?
+ (standard-print-method 'random-state))
+
(define-integrable (random-state-index s) (vector-ref s 1))
(define-integrable (set-random-state-index! s x) (vector-set! s 1 x))
'#(index borrow vector)
'#(1 2 3)
(make-vector 3 (lambda () #f))
- (standard-print-method 'random-state)
+ #f
random-state-tag
4)))
\ No newline at end of file
make-serial-population/unsafe
add-to-population!/unsafe)
(import (runtime gc-daemons)
- add-secondary-gc-daemon!/unsafe)
- (initialization (initialize-package!)))
+ add-secondary-gc-daemon!/unsafe))
(define-package (runtime 2d-property)
(files "prop2d")
(define-package (runtime global-database)
(files "gdatab")
(parent (runtime))
+ (export () deprecated:global-database
+ unparser/set-tagged-pair-method!
+ unparser/set-tagged-vector-method!)
(export ()
- add-unparser-special-object!
- add-unparser-special-pair!
event:after-restart
event:after-restore
event:before-exit
- named-structure/get-tag-description
- named-structure/set-tag-description!
- unparse-with-brackets
- unparser/set-tagged-pair-method!
- unparser/set-tagged-vector-method!
- unparser/tagged-pair-method
- unparser/tagged-vector-method)
- (initialization (initialize-package!)))
+ named-structure/set-tag-description!)
+ (export (runtime record)
+ named-structure/get-tag-description))
(define-package (runtime hash)
(files "hash")
(export () deprecated:hash-table
(eq-hash-table-type key-weak-eq-hash-table-type)
(eqv-hash-table-type key-weak-eqv-hash-table-type)
- (hash-table-entry-type:key/datum-weak hash-table-entry-type:key&datum-weak)
+ (hash-table-entry-type:key/datum-weak
+ hash-table-entry-type:key&datum-weak)
(hash-table/clean! hash-table-clean!)
(hash-table/clear! hash-table-clear!)
(hash-table/count hash-table-size)
map-over-population
map-over-population!
population?
- remove-from-population!)
- (initialization (initialize-package!)))
+ remove-from-population!))
(define-package (runtime pretty-printer)
(files "pp")
'#(waiting-threads owner)
'#(1 2)
(vector 2 (lambda () #f))
- (standard-print-method 'thread-mutex)
+ #f
thread-mutex-tag
3))
(named-structure/set-tag-description! link-tag
'#(prev next item)
'#(1 2 3)
(vector 3 (lambda () #f))
- (standard-print-method 'link)
+ #f
link-tag
4)))
+(define-print-method link?
+ (standard-print-method 'link))
+
(define (reset-threads!)
(reset-threads-low!)
(reset-threads-high!))
(waiting-threads (make-ring) read-only #t)
(owner #f))
+(define-print-method thread-mutex?
+ (standard-print-method 'thread-mutex))
+
(define-integrable (guarantee-thread-mutex mutex procedure)
(if (not (thread-mutex? mutex))
(error:wrong-type-argument mutex "thread-mutex" procedure)))
(define (unix/pathname->namestring pathname)
(string-append (print-directory (%pathname-directory pathname))
(print-name (%pathname-name pathname)
- (%pathname-type pathname))))
+ (%pathname-type pathname))))
(define (print-directory directory)
(cond ((not directory)
(define pathname-map/tag "pathname-map")
(define pathname-map/root-node cdr)
-(unparser/set-tagged-pair-method!
- pathname-map/tag
- (standard-print-method "PATHNAME-MAP"))
-
(declare (integrate-operator node/make))
(define (node/make)
(and (pair? object)
(eq? (car object) pathname-map/tag))))
+(define-print-method pathname-map?
+ (standard-print-method 'pathname-map))
+
(set! pathname-map/lookup
(named-lambda (pathname-map/lookup map pathname if-found if-not)
(let ((node
projects / mit-scheme.git / commitdiff