From 25f395c1d0f238a20deb37faa780efd800a294db Mon Sep 17 00:00:00 2001 From: mainzelm Date: Fri, 23 Mar 2001 12:45:31 +0000 Subject: [PATCH] * New package definitions now that we have SRFI-13 and 14 * Introduced the nomenclature "sigevent" --- scheme/rts/events.scm | 79 ----------------------- scheme/rts/init.scm | 2 +- scheme/rts/root-scheduler.scm | 2 +- scheme/rts/sigevents.scm | 82 ++++++++++++++++++++++++ scsh/event.scm | 24 ++++--- scsh/scsh-interfaces.scm | 114 ++++++---------------------------- scsh/scsh-package.scm | 36 +++++------ 7 files changed, 136 insertions(+), 203 deletions(-) delete mode 100644 scheme/rts/events.scm create mode 100644 scheme/rts/sigevents.scm diff --git a/scheme/rts/events.scm b/scheme/rts/events.scm deleted file mode 100644 index 51b0a67..0000000 --- a/scheme/rts/events.scm +++ /dev/null @@ -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))))) - diff --git a/scheme/rts/init.scm b/scheme/rts/init.scm index faa3ee7..5b8d562 100644 --- a/scheme/rts/init.scm +++ b/scheme/rts/init.scm @@ -30,7 +30,7 @@ (lambda () (with-threads (lambda () - (initialize-events!) + (initialize-sigevents!) (root-scheduler thunk 200 ; thread quantum, in msec 300)))))))))) ; port-flushing quantum diff --git a/scheme/rts/root-scheduler.scm b/scheme/rts/root-scheduler.scm index 57860fa..ba40533 100644 --- a/scheme/rts/root-scheduler.scm +++ b/scheme/rts/root-scheduler.scm @@ -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)) diff --git a/scheme/rts/sigevents.scm b/scheme/rts/sigevents.scm new file mode 100644 index 0000000..848606c --- /dev/null +++ b/scheme/rts/sigevents.scm @@ -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))))) + diff --git a/scsh/event.scm b/scsh/event.scm index 9d736bb..8c4581f 100644 --- a/scsh/event.scm +++ b/scsh/event.scm @@ -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?)) diff --git a/scsh/scsh-interfaces.scm b/scsh/scsh-interfaces.scm index cf71474..029ee64 100644 --- a/scsh/scsh-interfaces.scm +++ b/scsh/scsh-interfaces.scm @@ -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 diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index 71eb7e6..f4cc469 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -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)