scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

* New package definitions now that we have SRFI-13 and 14 

* Introduced the nomenclature "sigevent"
This commit is contained in:
mainzelm 2001-03-23 12:45:31 +00:00
parent 9b4bb8a19d
commit 25f395c1d0
7 changed files with 136 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
scheme/rts/events.scm
View File

@ -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)))))

2
scheme/rts/init.scm
View File

@ -30,7 +30,7 @@
(lambda ()
(with-threads
(lambda ()
(initialize-events!)
(initialize-sigevents!)
(root-scheduler thunk
200 ; thread quantum, in msec
300)))))))))) ; port-flushing quantum

2
scheme/rts/root-scheduler.scm
View File

@ -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))

82
scheme/rts/sigevents.scm Normal file
View File

@ -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)))))

24
scsh/event.scm
View File

@ -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?))

114
scsh/scsh-interfaces.scm
View File

@ -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

36
scsh/scsh-package.scm
View File

@ -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)