* New package definitions now that we have SRFI-13 and 14
* Introduced the nomenclature "sigevent"
This commit is contained in:
parent
9b4bb8a19d
commit
25f395c1d0
|
@ -1,79 +0,0 @@
|
|||
; Copyright (c) 1999-2001 by Martin Gasbichler. See file COPYING.
|
||||
|
||||
;;; Functional event system.
|
||||
;;; System by Olin Shivers, implementation by Martin Gasbichler
|
||||
|
||||
(define-record-type event :event
|
||||
(really-make-event type next)
|
||||
event?
|
||||
(type event-type set-event-type!)
|
||||
(next next-event set-next-event!))
|
||||
|
||||
(define (make-event type)
|
||||
(really-make-event type #f))
|
||||
|
||||
(define empty-event (make-event #f))
|
||||
|
||||
(define *most-recent-event* empty-event)
|
||||
|
||||
(define (most-recent-event) *most-recent-event*)
|
||||
|
||||
(define event-thread-queue #f)
|
||||
|
||||
;Wait for an event of a certain type.
|
||||
(define (rts-wait-interrupt set pre-event type-in-set?)
|
||||
(with-interrupts-inhibited
|
||||
(lambda ()
|
||||
(let lp ((event (next-event pre-event)))
|
||||
(if event
|
||||
(if (type-in-set? (event-type event) set)
|
||||
event
|
||||
(lp (next-event event)))
|
||||
(begin (enqueue-thread! event-thread-queue (current-thread))
|
||||
(block)
|
||||
(lp (next-event pre-event))))))))
|
||||
|
||||
; same as above, but don't block
|
||||
(define (rts-maybe-wait-interrupt set pre-event type-in-set?)
|
||||
(let ((event (next-event pre-event)))
|
||||
(if event
|
||||
(if (type-in-set? (event-type event) set)
|
||||
event
|
||||
(rts-maybe-wait-interrupt set (next-event event) type-in-set?))
|
||||
#f)))
|
||||
|
||||
|
||||
;Called when the interrupt actually happened.
|
||||
;;; TODO w-i-i is problaly not necessary since they're off already
|
||||
(define (register-interrupt type)
|
||||
(let ((waiters (with-interrupts-inhibited
|
||||
(lambda ()
|
||||
(set-next-event! *most-recent-event* (make-event type))
|
||||
(set! *most-recent-event* (next-event *most-recent-event*))
|
||||
(do ((waiters '() (cons (dequeue-thread! event-thread-queue)
|
||||
waiters)))
|
||||
((thread-queue-empty? event-thread-queue)
|
||||
waiters))))))
|
||||
(for-each make-ready waiters)))
|
||||
|
||||
;;; has to be called with interrupts disabled
|
||||
(define (waiting-for-os-event?)
|
||||
(not (thread-queue-empty? event-thread-queue)))
|
||||
|
||||
(define (initialize-events!)
|
||||
(set! event-thread-queue (make-thread-queue))
|
||||
(set-interrupt-handler! (enum interrupt os-signal)
|
||||
(lambda (type arg enabled-interrupts)
|
||||
; type is already set in the unix signal handler
|
||||
(register-interrupt type)))
|
||||
(set-interrupt-handler! (enum interrupt keyboard)
|
||||
(lambda (enabled-interrupts)
|
||||
(register-interrupt (enum interrupt keyboard))))
|
||||
; (call-after-gc! (lambda () (register-interrupt (enum interrupt post-gc))))
|
||||
)
|
||||
;;; the vm uses the timer for the scheduler
|
||||
(define (schedule-timer-interrupt! msec)
|
||||
(spawn (lambda ()
|
||||
(sleep msec)
|
||||
(register-interrupt (enum interrupt alarm)))))
|
||||
|
|
@ -30,7 +30,7 @@
|
|||
(lambda ()
|
||||
(with-threads
|
||||
(lambda ()
|
||||
(initialize-events!)
|
||||
(initialize-sigevents!)
|
||||
(root-scheduler thunk
|
||||
200 ; thread quantum, in msec
|
||||
300)))))))))) ; port-flushing quantum
|
||||
|
|
|
@ -98,7 +98,7 @@
|
|||
#t)
|
||||
((or time-until-wakeup
|
||||
(waiting-for-i/o?)
|
||||
(waiting-for-os-event?))
|
||||
(waiting-for-sigevent?))
|
||||
(do-some-waiting time-until-wakeup)
|
||||
(set-enabled-interrupts! all-interrupts)
|
||||
(root-wait))
|
||||
|
|
|
@ -0,0 +1,82 @@
|
|||
; Copyright (c) 1999-2001 by Martin Gasbichler. See file COPYING.
|
||||
|
||||
;;; Functional event system.
|
||||
;;; System by Olin Shivers, implementation by Martin Gasbichler
|
||||
|
||||
(define-record-type sigevent :sigevent
|
||||
(really-make-sigevent type next)
|
||||
sigevent?
|
||||
(type sigevent-type set-sigevent-type!)
|
||||
(next sigevent-next set-sigevent-next!))
|
||||
|
||||
(define (make-sigevent type)
|
||||
(really-make-sigevent type #f))
|
||||
|
||||
(define empty-sigevent (make-sigevent #f))
|
||||
|
||||
(define *most-recent-sigevent* empty-sigevent)
|
||||
|
||||
(define (most-recent-sigevent) *most-recent-sigevent*)
|
||||
|
||||
(define sigevent-thread-queue #f)
|
||||
|
||||
;Wait for an sigevent of a certain type.
|
||||
(define (rts-next-sigevent pre-sigevent set type-in-set?)
|
||||
(with-interrupts-inhibited
|
||||
(lambda ()
|
||||
(let lp ((pre-sigevent pre-sigevent))
|
||||
(let ((sigevent (sigevent-next pre-sigevent)))
|
||||
(if sigevent
|
||||
(if (type-in-set? (sigevent-type sigevent) set)
|
||||
sigevent
|
||||
(lp sigevent))
|
||||
(begin (enqueue-thread! sigevent-thread-queue (current-thread))
|
||||
(block)
|
||||
(lp pre-sigevent))))))))
|
||||
|
||||
; same as above, but don't block
|
||||
(define (rts-next-sigevent/no-wait pre-sigevent set type-in-set?)
|
||||
(let ((sigevent (sigevent-next pre-sigevent)))
|
||||
(if sigevent
|
||||
(if (type-in-set? (sigevent-type sigevent) set)
|
||||
sigevent
|
||||
(rts-next-sigevent/no-wait (sigevent-next sigevent)
|
||||
set
|
||||
type-in-set?))
|
||||
#f)))
|
||||
|
||||
|
||||
;Called when the interrupt actually happened.
|
||||
;;; TODO w-i-i is problaly not necessary since they're off already
|
||||
(define (register-interrupt type)
|
||||
(let ((waiters (with-interrupts-inhibited
|
||||
(lambda ()
|
||||
(set-sigevent-next! *most-recent-sigevent* (make-sigevent type))
|
||||
(set! *most-recent-sigevent* (sigevent-next *most-recent-sigevent*))
|
||||
(do ((waiters '() (cons (dequeue-thread! sigevent-thread-queue)
|
||||
waiters)))
|
||||
((thread-queue-empty? sigevent-thread-queue)
|
||||
waiters))))))
|
||||
(for-each make-ready waiters)))
|
||||
|
||||
;;; has to be called with interrupts disabled
|
||||
(define (waiting-for-sigevent?)
|
||||
(not (thread-queue-empty? sigevent-thread-queue)))
|
||||
|
||||
(define (initialize-sigevents!)
|
||||
(set! sigevent-thread-queue (make-thread-queue))
|
||||
(set-interrupt-handler! (enum interrupt os-signal)
|
||||
(lambda (type arg enabled-interrupts)
|
||||
; type is already set in the unix signal handler
|
||||
(register-interrupt type)))
|
||||
(set-interrupt-handler! (enum interrupt keyboard)
|
||||
(lambda (enabled-interrupts)
|
||||
(register-interrupt (enum interrupt keyboard))))
|
||||
; (call-after-gc! (lambda () (register-interrupt (enum interrupt post-gc))))
|
||||
)
|
||||
;;; the vm uses the timer for the scheduler
|
||||
(define (schedule-timer-interrupt! msec)
|
||||
(spawn (lambda ()
|
||||
(sleep msec)
|
||||
(register-interrupt (enum interrupt alarm)))))
|
||||
|
|
@ -2,15 +2,23 @@
|
|||
|
||||
;;; Extend the functions of the RTS
|
||||
|
||||
(define (wait-interrupt type pre-event)
|
||||
(rts-wait-interrupt type pre-event eq?))
|
||||
(define (next-sigevent pre-event type)
|
||||
(if (not (sigevent? pre-event))
|
||||
(error "pre-event is not an event"))
|
||||
(rts-next-sigevent pre-event type eq?))
|
||||
|
||||
(define (wait-interrupt-set set pre-event)
|
||||
(rts-wait-interrupt set pre-event interrupt-in-set?))
|
||||
(define (next-sigevent-set pre-event set)
|
||||
(if (not (sigevent? pre-event))
|
||||
(error "pre-event is not an event"))
|
||||
(rts-next-sigevent pre-event set interrupt-in-set?))
|
||||
|
||||
(define (maybe-wait-interrupt type pre-event)
|
||||
(rts-maybe-wait-interrupt type pre-event eq?))
|
||||
(define (next-sigevent/no-wait pre-event type)
|
||||
(if (not (sigevent? pre-event))
|
||||
(error "pre-event is not an event"))
|
||||
(rts-next-sigevent/no-wait pre-event type eq?))
|
||||
|
||||
(define (maybe-wait-interrupt-set set pre-event)
|
||||
(rts-maybe-wait-interrupt set pre-event interrupt-in-set?))
|
||||
(define (next-sigevent-set/no-wait set pre-event)
|
||||
(if (not (sigevent? pre-event))
|
||||
(error "pre-event is not an event"))
|
||||
(rts-next-sigevent/no-wait pre-event set interrupt-in-set?))
|
||||
|
||||
|
|
|
@ -315,7 +315,7 @@
|
|||
pid->proc
|
||||
|
||||
autoreap-policy
|
||||
install-autoreaping
|
||||
with-autoreaping
|
||||
reap-zombies
|
||||
|
||||
wait
|
||||
|
@ -701,80 +701,6 @@
|
|||
))
|
||||
|
||||
|
||||
(define-interface char-set-interface
|
||||
(export char:newline char:tab char:page char:return char:space char:vtab
|
||||
char-ascii?
|
||||
|
||||
char-set?
|
||||
char-set-copy
|
||||
char-set=
|
||||
char-set<=
|
||||
char-set-size
|
||||
|
||||
char-set-adjoin char-set-delete
|
||||
char-set-adjoin! char-set-delete!
|
||||
char-set-for-each
|
||||
char-set-fold reduce-char-set
|
||||
|
||||
char-set
|
||||
chars->char-set
|
||||
string->char-set
|
||||
ascii-range->char-set
|
||||
predicate->char-set
|
||||
->char-set
|
||||
|
||||
char-set-members
|
||||
char-set-contains?
|
||||
|
||||
char-set-every?
|
||||
char-set-any
|
||||
|
||||
char-set-invert
|
||||
char-set-union
|
||||
char-set-intersection
|
||||
char-set-difference
|
||||
|
||||
char-set-invert!
|
||||
char-set-union!
|
||||
char-set-intersection!
|
||||
char-set-difference!
|
||||
|
||||
char-set:lower-case
|
||||
char-set:upper-case
|
||||
char-set:alphabetic
|
||||
char-set:numeric
|
||||
char-set:alphanumeric
|
||||
char-set:graphic
|
||||
char-set:printing
|
||||
char-set:whitespace
|
||||
char-set:blank
|
||||
char-set:control
|
||||
char-set:punctuation
|
||||
char-set:hex-digit
|
||||
char-set:ascii
|
||||
char-set:empty
|
||||
char-set:full
|
||||
|
||||
char-lower-case?
|
||||
char-upper-case?
|
||||
char-alphabetic?
|
||||
char-numeric?
|
||||
char-alphanumeric?
|
||||
char-graphic?
|
||||
char-printing?
|
||||
char-whitespace?
|
||||
char-blank?
|
||||
char-control?
|
||||
char-punctuation?
|
||||
char-hex-digit?
|
||||
char-ascii?
|
||||
|
||||
;; This is not properly part of the interface,
|
||||
;; and should be moved to an internals interface --
|
||||
;; it is used by rdelim.scm code.
|
||||
char-set:s))
|
||||
|
||||
|
||||
(define-interface scsh-field-reader-interface
|
||||
(export join-strings
|
||||
field-splitter infix-splitter suffix-splitter sloppy-suffix-splitter
|
||||
|
@ -1075,7 +1001,7 @@
|
|||
interrupt-set
|
||||
|
||||
interrupt-handlers-vector ; JMG: replaces vm vector
|
||||
%install-scsh-handlers
|
||||
with-scsh-sighandlers
|
||||
|
||||
(with-enabled-interrupts :syntax)
|
||||
with-enabled-interrupts*
|
||||
|
@ -1111,16 +1037,14 @@
|
|||
interrupt/xfsz))
|
||||
|
||||
(define-interface scsh-events-interface
|
||||
(export most-recent-event
|
||||
|
||||
event?
|
||||
next-event
|
||||
event-type
|
||||
|
||||
wait-interrupt
|
||||
wait-interrupt-set
|
||||
maybe-wait-interrupt
|
||||
maybe-wait-interrupt-set))
|
||||
(export most-recent-sigevent
|
||||
sigevent?
|
||||
next-sigevent
|
||||
next-sigevent-set
|
||||
next-sigevent/no-wait
|
||||
next-sigevent-set/no-wait
|
||||
sigevent-type))
|
||||
|
||||
|
||||
(define-interface low-interrupt-interface
|
||||
(export number-of-interrupts
|
||||
|
@ -1160,15 +1084,15 @@
|
|||
(define-interface syslog-interface
|
||||
(export openlog
|
||||
syslog
|
||||
syslog-w/id
|
||||
closelog
|
||||
syslog-option/default
|
||||
syslog-option/cons
|
||||
syslog-option/ndelay
|
||||
syslog-option/pid
|
||||
syslog-facility/default
|
||||
syslog-facility/auth
|
||||
syslog-option/console-on-error
|
||||
syslog-option/open-now
|
||||
syslog-option/include-pid
|
||||
syslog-facility/authorisation
|
||||
syslog-facility/daemon
|
||||
syslog-facility/kern
|
||||
syslog-facility/kernel
|
||||
syslog-facility/local0
|
||||
syslog-facility/local1
|
||||
syslog-facility/local2
|
||||
|
@ -1181,10 +1105,10 @@
|
|||
syslog-facility/mail
|
||||
syslog-facility/user
|
||||
syslog-level/default
|
||||
syslog-level/emerg
|
||||
syslog-level/emergency
|
||||
syslog-level/alert
|
||||
syslog-level/crit
|
||||
syslog-level/err
|
||||
syslog-level/critical
|
||||
syslog-level/error
|
||||
syslog-level/warning
|
||||
syslog-level/notice
|
||||
syslog-level/info
|
||||
|
|
|
@ -61,16 +61,6 @@
|
|||
)
|
||||
|
||||
|
||||
(define-structure char-set-package char-set-interface
|
||||
(open error-package
|
||||
ascii
|
||||
define-record-types ; JAR's record macro.
|
||||
scsh-utilities ; For DEPRECATED-PROC
|
||||
scheme)
|
||||
(files char-set)
|
||||
; (optimize auto-integrate)
|
||||
)
|
||||
|
||||
|
||||
(define-structures ((tty-flags tty-flags-interface)
|
||||
(scsh-internal-tty-flags scsh-internal-tty-flags-interface))
|
||||
|
@ -142,7 +132,7 @@
|
|||
; (scsh-regexp-package scsh-regexp-interface)
|
||||
)
|
||||
(for-syntax (open scsh-syntax-helpers scheme))
|
||||
(access events scsh-events)
|
||||
(access sigevents scsh-events)
|
||||
(open enumerated
|
||||
defenum-package
|
||||
external-calls ;JMG new FFI
|
||||
|
@ -150,6 +140,7 @@
|
|||
cig-aux
|
||||
receiving
|
||||
defrec-package
|
||||
define-record-types
|
||||
define-foreign-syntax
|
||||
formats
|
||||
os-dependent ; OS dependent stuff
|
||||
|
@ -169,9 +160,10 @@
|
|||
fluids
|
||||
weak
|
||||
|
||||
scsh-char-set-low-level-lib ; rdelim.scm needs it.
|
||||
; scsh-regexp-package
|
||||
; scsh-regexp-internals
|
||||
char-set-package
|
||||
char-set-lib
|
||||
scsh-version
|
||||
tty-flags
|
||||
scsh-internal-tty-flags ; Not exported
|
||||
|
@ -291,7 +283,6 @@
|
|||
repl )
|
||||
(open command-processor
|
||||
command-levels ; with-new-session
|
||||
char-set-package
|
||||
ensures-loaded
|
||||
environments
|
||||
error-package
|
||||
|
@ -319,18 +310,21 @@
|
|||
|
||||
|
||||
(define-structure field-reader-package scsh-field-reader-interface
|
||||
(open receiving ; receive
|
||||
char-set-package
|
||||
scsh-utilities ; nth
|
||||
(open receiving ; receive
|
||||
scsh-utilities ; nth
|
||||
error-package ; error
|
||||
string-lib ; string-join for obsolete join-strings
|
||||
scsh-level-0 ; delimited readers
|
||||
; scsh-regexp-package
|
||||
re-exports
|
||||
string-lib ; join-strings
|
||||
let-opt ; optional-arg parsing & defaulting
|
||||
scheme
|
||||
)
|
||||
(files fr))
|
||||
(files fr)
|
||||
;; Handle a little bit of backwards compatibility.
|
||||
(begin (define join-strings (deprecated-proc string-join 'join-strings
|
||||
"Use SRFI-13 STRING-JOIN.")))
|
||||
)
|
||||
|
||||
|
||||
(define-structures
|
||||
|
@ -375,9 +369,12 @@
|
|||
; scsh-dbm-interface
|
||||
(export repl)
|
||||
awk-interface
|
||||
char-set-predicates-interface; Urk -- Some of this is R5RS!
|
||||
obsolete-char-set-interface
|
||||
)
|
||||
|
||||
(open structure-refs
|
||||
obsolete-char-set-lib
|
||||
scsh-level-0
|
||||
scsh-level-0-internals
|
||||
re-exports
|
||||
|
@ -387,6 +384,7 @@
|
|||
; dbm
|
||||
awk-package
|
||||
field-reader-package
|
||||
char-set-predicates-lib ; Urk -- Some of this is R5RS!
|
||||
dot-locking
|
||||
scheme)
|
||||
|
||||
|
@ -408,7 +406,7 @@
|
|||
scheme
|
||||
structure-refs
|
||||
low-interrupt
|
||||
events)
|
||||
sigevents)
|
||||
(files event))
|
||||
|
||||
(define-structure simple-syntax (export define-simple-syntax)
|
||||
|
|
Loading…
Reference in New Issue