scsh-0.6/scheme/rts-packages.scm

357 lines
11 KiB
Scheme

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
(define-structures ((scheme-level-1 scheme-level-1-interface)
(util util-interface))
(open scheme-level-0 ascii signals
code-quote) ; needed by SYNTAX-RULES
(usual-transforms case quasiquote syntax-rules)
(files (rts base)
(rts util)
(rts number)
(rts lize)) ; Rationalize
(optimize auto-integrate))
; "Level 2"
(define-structures ((records records-interface)
(records-internal records-internal-interface))
(open scheme-level-1 signals
primitives)
(files (rts record))
(optimize auto-integrate))
; The external code needs this to check the types of records.
(define-structure export-the-record-type (export)
(open scheme-level-1 records-internal shared-bindings)
(begin
(define-exported-binding "s48-the-record-type" :record-type)))
(define-structure define-record-types define-record-types-interface
(open scheme-level-1 records records-internal loopholes
primitives) ; unspecific
(files (rts jar-defrecord)))
(define-structures ((methods methods-interface)
(meta-methods meta-methods-interface))
(open scheme-level-1
define-record-types
records records-internal
bitwise util primitives
signals)
(files (rts method))
(optimize auto-integrate))
(define-structure number-i/o number-i/o-interface
(open scheme-level-1 methods signals ascii)
(files (rts numio)))
(define-structures ((fluids fluids-interface)
(fluids-internal fluids-internal-interface)
(thread-cells thread-cells-interface)
(thread-cells-internal thread-cells-internal-interface))
(open scheme-level-1 define-record-types primitives cells)
(files (rts thread-env))
(optimize auto-integrate))
(define-structure wind wind-interface
(open scheme-level-1 signals define-record-types
fluids fluids-internal
escapes)
(files (rts wind))
(optimize auto-integrate))
(define-structure session-data (export make-session-data-slot!
initialize-session-data!
session-data-ref
session-data-set!)
(open scheme-level-1
primitives)
(files (rts session))
(optimize auto-integrate))
(define-structures ((i/o i/o-interface)
(i/o-internal i/o-internal-interface))
(open scheme-level-1 signals fluids
architecture
primitives ports code-vectors bitwise
define-record-types ascii
threads locks
threads-internal ; JMG for scsh
methods ; &disclose :input-port :output-port
interrupts ; {en|dis}able-interrupts!
number-i/o ; number->string for debugging
exceptions ; wrong-number-of-args stuff
handle) ; report-errors-as-warnings with-handler
(files (rts port)
(rts current-port))
(optimize auto-integrate))
(define-structure channels channels-interface
(open scheme-level-1
low-channels
architecture
signals) ; error, call-error
(files (rts channel)))
(define-structure channel-i/o channel-i/o-interface
(open scheme-level-1 i/o i/o-internal signals
channels low-channels
architecture code-vectors wind
define-record-types
queues threads threads-internal locks cells
exceptions interrupts
ascii ports util
session-data
structure-refs
debug-messages ; for error messages
handle) ; report-errors-as-warnings
(access primitives) ; add-finalizer, channel stuff
(files (rts channel-port)
(rts channel-io)))
(define-structure conditions conditions-interface
(open scheme-level-1 signals)
(files (rts condition)))
(define-structure writing writing-interface
(open scheme-level-1
number-i/o
i/o ;output-port-option, write-string
methods ;disclose
structure-refs)
(access low-channels ;channel? channel-id
code-vectors) ;code-vector?
(files (rts write)))
(define-structure reading reading-interface
(open scheme-level-1
number-i/o
i/o ;input-port-option
ascii ;for dispatch table
signals ;warn, signal-condition, make-condition
conditions ;define-condition-type
primitives ;make-immutable!
silly) ;reverse-list->string
(files (rts read))
(optimize auto-integrate))
(define-structure scheme-level-2 scheme-level-2-interface
(open scheme-level-1
number-i/o
writing
reading
wind
i/o
channel-i/o))
(define-structure features features-interface
(open primitives i/o))
; Hairier stuff now.
(define-structure templates templates-interface
(open scheme-level-1 primitives methods)
(files (rts template))
(optimize auto-integrate))
(define-structure continuations continuations-interface
(open scheme-level-1 primitives templates methods architecture code-vectors)
(files (rts continuation))
(optimize auto-integrate))
(define-structure more-types (export :closure :code-vector :location :double
:template :channel :port :weak-pointer
:shared-binding)
(open scheme-level-1 methods
closures code-vectors locations templates low-channels ports primitives
shared-bindings)
(begin (define-simple-type :closure (:value) closure?)
(define-simple-type :code-vector (:value) code-vector?)
(define-simple-type :location (:value) location?)
(define-simple-type :template (:value) template?)
(define-simple-type :channel (:value) channel?)
(define-simple-type :port (:value) port?)
(define-simple-type :double (:rational) double?)
(define-simple-type :weak-pointer (:value) weak-pointer?)
(define-method &disclose ((obj :weak-pointer)) (list 'weak-pointer))
(define-simple-type :shared-binding (:value) shared-binding?)
(define-method &disclose ((obj :shared-binding))
(list (if (shared-binding-is-import? obj)
'imported-binding
'exported-binding)
(shared-binding-name obj)))))
(define-structure enumerated enumerated-interface
(open scheme-level-1 signals)
(files (rts defenum scm)))
(define-structure architecture architecture-interface
(open scheme-level-1 signals enumerated)
(files (vm arch)))
(define-structures ((exceptions exceptions-interface)
(handle handle-interface))
(open scheme-level-1
signals fluids
conditions ;make-exception, etc.
primitives ;set-exception-handlers!, etc.
wind ;CWCC
methods
meta-methods
more-types
architecture
vm-exposure ;primitive-catch
templates ;template-code, template-info
continuations ;continuation-pc, etc.
locations ;location?, location-id
closures ;closure-template
number-i/o) ; number->string, for backtrace
(files (rts exception))) ; Needs generic, arch
(define-structure interrupts interrupts-interface
(open scheme-level-1
signals fluids conditions
bitwise
escapes
session-data
primitives
architecture)
(files (rts interrupt))
(optimize auto-integrate)) ;mostly for threads package...
(define-structures ((rts-sigevents rts-sigevents-interface)
(rts-sigevents-internal rts-sigevents-internal-interface))
(open scheme-level-1 define-record-types queues
threads threads-internal
wind
interrupts
architecture)
(files (rts sigevents))
(optimize auto-integrate))
(define-structures ((threads threads-interface)
(threads-internal threads-internal-interface))
(open scheme-level-1 enumerated define-record-types queues cells
interrupts
wind
fluids
fluids-internal ;get-dynamic-env
thread-cells-internal ;get-thread-cell-env, empty-thread-cell-env
escapes ;primitive-cwcc
conditions ;error?
handle ;with-handler
signals ;signal, warn
loopholes ;for converting #f to a continuation
architecture ;time-option
session-data
debug-messages
structure-refs)
(access primitives) ;time current-thread set-current-thread! etc.
(optimize auto-integrate)
(files (rts thread) (rts sleep)))
(define-structure scheduler scheduler-interface
(open scheme-level-1 threads threads-internal locks
enumerated enum-case
queues
debug-messages
signals) ;error
(files (rts scheduler)))
(define-structure root-scheduler (export root-scheduler
spawn-on-root
scheme-exit-now
call-when-deadlocked!)
(open scheme-level-1 threads threads-internal scheduler structure-refs
queues
session-data
signals ;error
handle ;with-handler
i/o ;current-error-port
conditions ;warning?, error?
writing ;display
i/o-internal ;output-port-forcer, output-forcer-id
fluids-internal ;get-dynamic-env
interrupts ;with-interrupts-inhibited
wind ;call-with-current-continuation
channel-i/o ;waiting-for-i/o?
rts-sigevents-internal) ;waiting-for-os-sigevent?
(access primitives) ;unspecific, wait
(files (rts root-scheduler)))
(define-structure enum-case (export (enum-case :syntax))
(open scheme-level-1 enumerated util)
(begin
(define-syntax enum-case
(syntax-rules (else)
((enum-case enumeration (x ...) clause ...)
(let ((temp (x ...)))
(enum-case enumeration temp clause ...)))
((enum-case enumeration value ((name ...) body ...) rest ...)
(if (or (= value (enum enumeration name)) ...)
(begin body ...)
(enum-case enumeration value rest ...)))
((enum-case enumeration value (else body ...))
(begin body ...))
((enum-case enumeration value)
(unspecific))))))
(define-structure queues queues-interface
(open scheme-level-1 define-record-types signals
debug-messages)
(files (big queue))
(optimize auto-integrate))
; No longer used
;(define-structure linked-queues (compound-interface
; queues-interface
; (export delete-queue-entry!
; queue-head))
; (open scheme-level-1 define-record-types signals primitives)
; (files (big linked-queue))
; (optimize auto-integrate))
(define-structure locks locks-interface
(open scheme-level-1 define-record-types queues interrupts threads threads-internal)
(optimize auto-integrate)
(files (rts lock)))
(define-structure usual-resumer (export usual-resumer)
(open scheme-level-1
i/o ;initialize-i/o, etc.
channel-i/o ;{in,out}put-channel->port, initialize-channel-i/o
session-data ;initialize-session-data!
fluids-internal ;initialize-dynamic-state!
exceptions ;initialize-exceptions!
interrupts ;initialize-interrupts!
rts-sigevents-internal ;with-sigevents
records-internal ;initialize-records!
export-the-record-type ;just what it says
threads-internal ;start threads
root-scheduler) ;start a scheduler
(files (rts init)))
; Weak pointers & populations
(define-structure weak weak-interface
(open scheme-level-1 signals
primitives) ;Open primitives instead of loading (alt weak)
(files ;;(alt weak) ;Only needed if VM's weak pointers are buggy
(rts population)))
; Utility for displaying error messages
(define-structure display-conditions display-conditions-interface
(open scheme-level-2
writing
methods
handle) ;ignore-errors
(files (env dispcond)))