From fe4db825e681d1ddfd06872aee3bdedd3b896e05 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 14 Dec 1987 00:15:38 +0000 Subject: [PATCH] Change `System_Clock' to `OS_process_clock', scaling in milliseconds instead of centiseconds. Implement `real-time-clock' primitive. Implement "suspension" feature which generates special interrupt. This feature is activated by SIGHUP. --- v7/src/microcode/sysprim.c | 136 ++++++++++++++++--------------------- v7/src/microcode/version.h | 4 +- v7/src/runtime/intrpt.scm | 18 +++-- v7/src/runtime/sysclk.scm | 55 ++++++++------- v8/src/microcode/version.h | 4 +- 5 files changed, 106 insertions(+), 111 deletions(-) diff --git a/v7/src/microcode/sysprim.c b/v7/src/microcode/sysprim.c index 7e60b0247..117200185 100644 --- a/v7/src/microcode/sysprim.c +++ b/v7/src/microcode/sysprim.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sysprim.c,v 9.27 1987/11/17 08:18:22 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sysprim.c,v 9.28 1987/12/14 00:11:30 cph Rel $ * * Random system primitives. Most are implemented in terms of * utilities in os.c @@ -41,52 +41,50 @@ MIT in each case. */ /* Interrupt primitives */ -Built_In_Primitive(Prim_Chk_And_Cln_Input_Channel, 2, - "CHECK-AND-CLEAN-UP-INPUT-CHANNEL", 0x107) -Define_Primitive(Prim_Chk_And_Cln_Input_Channel, 2, - "CHECK-AND-CLEAN-UP-INPUT-CHANNEL") +DEFINE_PRIMITIVE ("CHECK-AND-CLEAN-UP-INPUT-CHANNEL", Prim_Chk_And_Cln_Input_Channel, 2) { extern Boolean OS_Clean_Interrupt_Channel(); - Primitive_2_Args(); + PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN(OS_Clean_Interrupt_Channel(Get_Integer(Arg1), - Get_Integer(Arg2)) ? - TRUTH : NIL); + PRIMITIVE_RETURN + ((OS_Clean_Interrupt_Channel ((arg_nonnegative_integer (1)), + (arg_nonnegative_integer (2)))) + ? TRUTH : NIL); } -Built_In_Primitive(Prim_Get_Next_Interrupt_Char, 0, - "GET-NEXT-INTERRUPT-CHARACTER", 0x106) -Define_Primitive(Prim_Get_Next_Interrupt_Char, 0, - "GET-NEXT-INTERRUPT-CHARACTER") +DEFINE_PRIMITIVE ("GET-NEXT-INTERRUPT-CHARACTER", Prim_Get_Next_Interrupt_Char, 0) { int result; extern int OS_Get_Next_Interrupt_Character(); - Primitive_0_Args(); + PRIMITIVE_HEADER (0); - result = OS_Get_Next_Interrupt_Character(); + result = (OS_Get_Next_Interrupt_Character ()); if (result == -1) - { - Primitive_Error(ERR_EXTERNAL_RETURN); - /*NOTREACHED*/ - } - CLEAR_INTERRUPT(INT_Character); - PRIMITIVE_RETURN(Make_Unsigned_Fixnum(result)); + { + Primitive_Error (ERR_EXTERNAL_RETURN); + /*NOTREACHED*/ + } + CLEAR_INTERRUPT (INT_Character); + PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (result)); } /* Time primitives */ -Built_In_Primitive(Prim_System_Clock, 0, "SYSTEM-CLOCK", 0x109) -Define_Primitive(Prim_System_Clock, 0, "SYSTEM-CLOCK") +DEFINE_PRIMITIVE ("SYSTEM-CLOCK", Prim_System_Clock, 0) +{ + PRIMITIVE_HEADER (0); + + PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (OS_process_clock ())); +} + +DEFINE_PRIMITIVE ("REAL-TIME-CLOCK", Prim_real_time_clock, 0) { - Primitive_0_Args(); + PRIMITIVE_HEADER (0); - PRIMITIVE_RETURN(Make_Unsigned_Fixnum(System_Clock())); + PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (OS_real_time_clock ())); } -Built_In_Primitive(Prim_Setup_Timer_Interrupt, 2, - "SETUP-TIMER-INTERRUPT", 0x153) -Define_Primitive(Prim_Setup_Timer_Interrupt, 2, - "SETUP-TIMER-INTERRUPT") +DEFINE_PRIMITIVE ("SETUP-TIMER-INTERRUPT", Prim_Setup_Timer_Interrupt, 2) { extern void Clear_Int_Timer(), Set_Int_Timer(); Primitive_2_Args(); @@ -110,79 +108,64 @@ Define_Primitive(Prim_Setup_Timer_Interrupt, 2, /* Date and current time primitives */ #define Date_Primitive(OS_Name) \ -{ \ int result; \ extern int OS_Name(); \ - Primitive_0_Args(); \ + PRIMITIVE_HEADER (0); \ \ - result = OS_Name(); \ - PRIMITIVE_RETURN((result == -1) ? \ - NIL : \ - (Make_Unsigned_Fixnum(result))); \ -} + result = (OS_Name ()); \ + PRIMITIVE_RETURN ((result == -1) ? NIL : (MAKE_UNSIGNED_FIXNUM (result))) -Built_In_Primitive(Prim_Current_Year, 0, "CURRENT-YEAR", 0x126) -Define_Primitive(Prim_Current_Year, 0, "CURRENT-YEAR") -Date_Primitive(OS_Current_Year) +DEFINE_PRIMITIVE ("CURRENT-YEAR", Prim_current_year, 0) +{ Date_Primitive (OS_Current_Year); } -Built_In_Primitive(Prim_Current_Month, 0, "CURRENT-MONTH", 0x127) -Define_Primitive(Prim_Current_Month, 0, "CURRENT-MONTH") -Date_Primitive(OS_Current_Month) +DEFINE_PRIMITIVE ("CURRENT-MONTH", Prim_current_month, 0) +{ Date_Primitive (OS_Current_Month); } -Built_In_Primitive(Prim_Current_Day, 0, "CURRENT-DAY", 0x128) -Define_Primitive(Prim_Current_Day, 0, "CURRENT-DAY") -Date_Primitive(OS_Current_Day) +DEFINE_PRIMITIVE ("CURRENT-DAY", Prim_current_day, 0) +{ Date_Primitive (OS_Current_Day); } -Built_In_Primitive(Prim_Current_Hour, 0, "CURRENT-HOUR", 0x129) -Define_Primitive(Prim_Current_Hour, 0, "CURRENT-HOUR") -Date_Primitive(OS_Current_Hour) +DEFINE_PRIMITIVE ("CURRENT-HOUR", Prim_current_hour, 0) +{ Date_Primitive (OS_Current_Hour); } -Built_In_Primitive(Prim_Current_Minute, 0, "CURRENT-MINUTE", 0x12A) -Define_Primitive(Prim_Current_Minute, 0, "CURRENT-MINUTE") -Date_Primitive(OS_Current_Minute) +DEFINE_PRIMITIVE ("CURRENT-MINUTE", Prim_current_minute, 0) +{ Date_Primitive (OS_Current_Minute); } -Built_In_Primitive(Prim_Current_Second, 0, "CURRENT-SECOND", 0x12B) -Define_Primitive(Prim_Current_Second, 0, "CURRENT-SECOND") -Date_Primitive(OS_Current_Second) +DEFINE_PRIMITIVE ("CURRENT-SECOND", Prim_current_second, 0) +{ Date_Primitive (OS_Current_Second); } /* Pretty random primitives */ /* (EXIT) - Halt SCHEME, with no intention of restarting. -*/ + Halt SCHEME, with no intention of restarting. */ -Built_In_Primitive(Prim_Non_Restartable_Exit, 0, "EXIT", 0x16) -Define_Primitive(Prim_Non_Restartable_Exit, 0, "EXIT") +DEFINE_PRIMITIVE ("EXIT", Prim_Non_Restartable_Exit, 0) { - Primitive_0_Args(); + PRIMITIVE_HEADER (0); - Microcode_Termination(TERM_HALT); + Microcode_Termination (TERM_HALT); } /* (HALT) Halt Scheme in such a way that it can be restarted. - Not all operating systems support this. -*/ -Built_In_Primitive(Prim_Restartable_Exit, 0, "HALT", 0x1A) -Define_Primitive(Prim_Restartable_Exit, 0, "HALT") + Not all operating systems support this. */ + +DEFINE_PRIMITIVE ("HALT", Prim_Restartable_Exit, 0) { extern Boolean Restartable_Exit(); - Primitive_0_Args(); + PRIMITIVE_HEADER (0); - PRIMITIVE_RETURN((Restartable_Exit() ? TRUTH : NIL)); + PRIMITIVE_RETURN (((Restartable_Exit ()) ? TRUTH : NIL)); } /* (SET-RUN-LIGHT! OBJECT) On the HP Pascal workstation system, it allows the character displayed in the lower right-hand part of the screen to be changed. In CScheme, rings the bell. - Used by various things to indicate the state of the system. -*/ + Used by various things to indicate the state of the system. */ -Built_In_Primitive(Prim_Set_Run_Light, 1, "SET-RUN-LIGHT!", 0xC0) -Define_Primitive(Prim_Set_Run_Light, 1, "SET-RUN-LIGHT!") +DEFINE_PRIMITIVE ("SET-RUN-LIGHT!", Prim_Set_Run_Light, 1) { - Primitive_1_Arg(); + PRIMITIVE_HEADER (1); #ifdef RUN_LIGHT_IS_BEEP { @@ -190,18 +173,17 @@ Define_Primitive(Prim_Set_Run_Light, 1, "SET-RUN-LIGHT!") OS_tty_beep(); OS_Flush_Output_Buffer(); - PRIMITIVE_RETURN(TRUTH); + PRIMITIVE_RETURN (TRUTH); } #else - PRIMITIVE_RETURN(NIL); + PRIMITIVE_RETURN (NIL); #endif } -Built_In_Primitive( Prim_under_emacs_p, 0, "UNDER-EMACS?", 0x1A1) -Define_Primitive( Prim_under_emacs_p, 0, "UNDER-EMACS?") +DEFINE_PRIMITIVE ("UNDER-EMACS?", Prim_under_emacs_p, 0) { extern Boolean OS_Under_Emacs(); - Primitive_0_Args(); + PRIMITIVE_HEADER (0); - PRIMITIVE_RETURN((OS_Under_Emacs() ? TRUTH : NIL)); + PRIMITIVE_RETURN (((OS_Under_Emacs ()) ? TRUTH : NIL)); } diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index 7254eafc9..cb1495dbf 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 10.12 1987/12/09 22:34:59 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 10.13 1987/12/14 00:14:47 cph Exp $ This file contains version information for the microcode. */ @@ -46,7 +46,7 @@ This file contains version information for the microcode. */ #define VERSION 10 #endif #ifndef SUBVERSION -#define SUBVERSION 12 +#define SUBVERSION 13 #endif #ifndef UCODE_TABLES_FILENAME diff --git a/v7/src/runtime/intrpt.scm b/v7/src/runtime/intrpt.scm index b7e625471..251c74dbb 100644 --- a/v7/src/runtime/intrpt.scm +++ b/v7/src/runtime/intrpt.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 13.46 1987/11/22 22:16:08 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 13.47 1987/12/14 00:13:58 cph Rel $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -65,11 +65,18 @@ ;;;; Soft interrupts -;;; Timer interrupts - (define (timer-interrupt-handler interrupt-code interrupt-enables) (timer-interrupt)) +(define (suspend-interrupt-handler interrupt-code interrupt-enables) + (fluid-let (((access *error-hook* error-system) + (lambda (environment message irritant substitute-environment?) + (%exit)))) + (disk-save (merge-pathnames (string->pathname "scheme_suspend") + (home-directory-pathname)) + true)) + (%exit)) + ;;; Keyboard Interrupts (define (external-interrupt-handler interrupt-code interrupt-enables) @@ -180,7 +187,8 @@ (define gc-slot 2) (define character-slot 4) (define timer-slot 6) -(define illegal-interrupt-slot 8) +(define suspend-slot 8) +(define illegal-interrupt-slot 9) (define (illegal-interrupt-handler interrupt-code interrupt-enables) (error "Illegal interrupt" interrupt-code interrupt-enables)) @@ -218,6 +226,8 @@ external-interrupt-handler) (vector-set! system-interrupt-vector timer-slot timer-interrupt-handler) + (vector-set! system-interrupt-vector suspend-slot + suspend-interrupt-handler) (vector-set! system-interrupt-vector illegal-interrupt-slot illegal-interrupt-handler) diff --git a/v7/src/runtime/sysclk.scm b/v7/src/runtime/sysclk.scm index 6dcd2aee2..58b5c542f 100644 --- a/v7/src/runtime/sysclk.scm +++ b/v7/src/runtime/sysclk.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysclk.scm,v 13.41 1987/01/23 00:21:27 jinx Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysclk.scm,v 13.42 1987/12/14 00:15:38 cph Rel $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -41,54 +41,57 @@ (declare (usual-integrations)) +(define process-time-clock + (make-primitive-procedure 'SYSTEM-CLOCK 0)) + +(define real-time-clock + (make-primitive-procedure 'REAL-TIME-CLOCK 0)) + (define system-clock) (define runtime) (define measure-interval) (define wait-interval) - -(let ((primitive-clock (make-primitive-procedure 'SYSTEM-CLOCK)) - (offset-time) - (non-runtime)) +(let ((offset-time) (non-runtime)) (define (clock) - (- (primitive-clock) offset-time)) + (- (process-time-clock) offset-time)) (define (ticks->seconds ticks) - (/ ticks 100)) + (/ ticks 1000)) (define (seconds->ticks seconds) - (* seconds 100)) + (* seconds 1000)) (define (reset-system-clock!) - (set! offset-time (primitive-clock)) + (set! offset-time (process-time-clock)) (set! non-runtime 0)) (reset-system-clock!) (add-event-receiver! event:after-restore reset-system-clock!) (set! system-clock - (named-lambda (system-clock) - (ticks->seconds (clock)))) + (named-lambda (system-clock) + (ticks->seconds (clock)))) (set! runtime - (named-lambda (runtime) - (ticks->seconds (- (clock) non-runtime)))) + (named-lambda (runtime) + (ticks->seconds (- (clock) non-runtime)))) (set! measure-interval - (named-lambda (measure-interval runtime? thunk) - (let ((start (clock))) - (let ((receiver (thunk (ticks->seconds start)))) - (let ((end (clock))) - (if (not runtime?) - (set! non-runtime (+ (- end start) non-runtime))) - (receiver (ticks->seconds end))))))) + (named-lambda (measure-interval runtime? thunk) + (let ((start (clock))) + (let ((receiver (thunk (ticks->seconds start)))) + (let ((end (clock))) + (if (not runtime?) + (set! non-runtime (+ (- end start) non-runtime))) + (receiver (ticks->seconds end))))))) (set! wait-interval - (named-lambda (wait-interval number-of-seconds) - (let ((end (+ (clock) (seconds->ticks number-of-seconds)))) - (let wait-loop () - (if (< (clock) end) - (wait-loop)))))) + (named-lambda (wait-interval number-of-seconds) + (let ((end (+ (clock) (seconds->ticks number-of-seconds)))) + (let wait-loop () + (if (< (clock) end) + (wait-loop)))))) ;;; end LET. -) +) \ No newline at end of file diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index 8c13f6ccc..4890ca8b7 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 10.12 1987/12/09 22:34:59 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 10.13 1987/12/14 00:14:47 cph Exp $ This file contains version information for the microcode. */ @@ -46,7 +46,7 @@ This file contains version information for the microcode. */ #define VERSION 10 #endif #ifndef SUBVERSION -#define SUBVERSION 12 +#define SUBVERSION 13 #endif #ifndef UCODE_TABLES_FILENAME -- 2.25.1