ref: 64ed7785525654984f16cc4aadd25bd5e3a3331e
parent: 718ef6cff985a419b3467bdad256bd866e53d772
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Sun Mar 9 17:19:52 EDT 2025
add (add-exit-hook f) to call functions with the exit status
--- a/boot/sl.boot
+++ b/boot/sl.boot
@@ -15,8 +15,8 @@
*properties* #table(*funvars* #table(*prompt* (NIL) lz-unpack ((data :to destination)
(data :size
decompressed-bytes)) void? ((x)) >= ((a . rest)) help ((term)) length= ((lst
- n)) doc-for ((term (doc NIL))) rand-u32 (NIL) = ((a . rest)) rand-u64 (NIL) car ((lst)) <= ((a . rest)) /= ((a . rest)) lz-pack ((data
- (level 0))) rand (NIL) nan? ((x)) rand-float (NIL) void (rest) cons? ((value)) vm-stats (NIL) * ((number…)) rand-double (NIL) cdr ((lst)) + ((number…)) > ((a . rest))) *doc* #table(>= "Return T if the arguments are in non-increasing order (previous\none is greater than or equal to the next one)." void? "Return T if x is #<void>, NIL otherwise." length= "Bounded length test.\nUse this instead of (= (length lst) n), since it avoids unnecessary\nwork and always terminates." doc-for "Define documentation for a top level term.\nIf the optional doc argument is missing and the term is a function\nsignture, adds it to the documentation." car "Return the first element of a list or NIL if not available." *builtins* "VM instructions as closures." <= "Return T if the arguments are in non-decreasing order (previous\none is less than or equal to the next one)." void "Return the constant #<void> while ignoring any arguments.\n#<void> is mainly used when a function has side effects but does not\nproduce any meaningful value to return, so even though T or NIL could\nbe returned instead, in case of #<void> alone, REPL will not print\nit." rand "Return a random non-negative fixnum on its maximum range." nan? "Return T if the argument is NaN, regardless of the sign." Instructions "VM instructions mapped to their encoded byte representation." rand-double "Return a random double on [0.0, 1.0] interval." > "Return T if the arguments are in strictly decreasing order (previous\none is greater than the next one)." cdr "Return the tail of a list or NIL if not available." + "Return sum of the numbers or 0 with no arguments." lz-unpack "Return decompressed data previously compressed using lz-pack.\nEither destination for the decompressed data or the expected size of\nthe decompressed data must be specified. In the latter case a new\narray is allocated." help "Display documentation for the specified term, if available." rand-u32 "Return a random integer on [0, 2³²-1] interval." = "Return T if the arguments are equal." rand-u64 "Return a random integer on [0, 2⁶⁴-1] interval." /= "Return T if not all arguments are equal. Shorthand for (not (= …))." lz-pack "Return data compressed using Lempel-Ziv.\nThe data must be an array, returned value will have the same type.\nThe optional level is between 0 and 10. With level 0 a simple LZSS\nusing hashing will be performed. Levels between 1 and 9 offer a\ntrade-off between time/space and ratio. Level 10 is optimal but very\nslow." arg-counts "VM instructions mapped to their expected arguments count." rand-float "Return a random float on [0.0, 1.0] interval." *prompt* "Function called by REPL to signal the user input is required.\nDefault function prints \"#;> \"." cons? "Return T if the value is a cons cell." vm-stats "Print various VM-related information, such as the number of GC calls\nso far, heap and stack size, etc." * "Return product of the numbers or 1 with no arguments." *properties* "All properties of symbols recorded with putprop are recorded in this table."))
+ n)) __finish ((status)) doc-for ((term (doc NIL))) rand-u32 (NIL) = ((a . rest)) rand-u64 (NIL) car ((lst)) <= ((a . rest)) add-exit-hook ((fun)) /= ((a . rest)) lz-pack ((data
+ (level 0))) rand (NIL) nan? ((x)) rand-float (NIL) void (rest) cons? ((value)) vm-stats (NIL) * ((number…)) rand-double (NIL) cdr ((lst)) + ((number…)) > ((a . rest))) *doc* #table(>= "Return T if the arguments are in non-increasing order (previous\none is greater than or equal to the next one)." void? "Return T if x is #<void>, NIL otherwise." length= "Bounded length test.\nUse this instead of (= (length lst) n), since it avoids unnecessary\nwork and always terminates." doc-for "Define documentation for a top level term.\nIf the optional doc argument is missing and the term is a function\nsignture, adds it to the documentation." car "Return the first element of a list or NIL if not available." *builtins* "VM instructions as closures." <= "Return T if the arguments are in non-decreasing order (previous\none is less than or equal to the next one)." void "Return the constant #<void> while ignoring any arguments.\n#<void> is mainly used when a function has side effects but does not\nproduce any meaningful value to return, so even though T or NIL could\nbe returned instead, in case of #<void> alone, REPL will not print\nit." rand "Return a random non-negative fixnum on its maximum range." nan? "Return T if the argument is NaN, regardless of the sign." Instructions "VM instructions mapped to their encoded byte representation." rand-double "Return a random double on [0.0, 1.0] interval." > "Return T if the arguments are in strictly decreasing order (previous\none is greater than the next one)." cdr "Return the tail of a list or NIL if not available." + "Return sum of the numbers or 0 with no arguments." __finish "A function called right before exit by the VM." lz-unpack "Return decompressed data previously compressed using lz-pack.\nEither destination for the decompressed data or the expected size of\nthe decompressed data must be specified. In the latter case a new\narray is allocated." help "Display documentation for the specified term, if available." rand-u32 "Return a random integer on [0, 2³²-1] interval." = "Return T if the arguments are equal." rand-u64 "Return a random integer on [0, 2⁶⁴-1] interval." add-exit-hook "Puts an one-argument function on top of the list of exit hooks.\nOn shutdown each exit hook is called with the exit status as a single\nargument, which is (usually) 0 on success and any other number on\nerror." /= "Return T if not all arguments are equal. Shorthand for (not (= …))." lz-pack "Return data compressed using Lempel-Ziv.\nThe data must be an array, returned value will have the same type.\nThe optional level is between 0 and 10. With level 0 a simple LZSS\nusing hashing will be performed. Levels between 1 and 9 offer a\ntrade-off between time/space and ratio. Level 10 is optimal but very\nslow." arg-counts "VM instructions mapped to their expected arguments count." rand-float "Return a random float on [0.0, 1.0] interval." *prompt* "Function called by REPL to signal the user input is required.\nDefault function prints \"#;> \"." cons? "Return T if the value is a cons cell." vm-stats "Print various VM-related information, such as the number of GC calls\nso far, heap and stack size, etc." * "Return product of the numbers or 1 with no arguments." *properties* "All properties of symbols recorded with putprop are recorded in this table."))
*syntax-environment* #table(bcode:nconst #fn("n1200r2e3:" #(aref)) doc-for #fn("\x8710002000W1000J60q?140B86;35040<;J404086;35040=863H020212287e212288e2e4e2:20212287e21e3e2:" #(void symbol-set-doc quote)) with-input-from #fn("z12021e1220e2e1e12315163:" #(#fn(nconc)with-bindings
@@ -54,10 +54,12 @@
> #fn("z1Ib6862086>1_486<^10162:" #(#fn("n21S;JE041<0L2;3;04A<1<1=62:" #())) >) >= #fn("z1Ib6862086>1_486<^10162:" #(#fn("n21S;JL0401<L2;J5040V340q:A<1<1=62:" #())) >=)Instructions #table(call.l #byte(0x51) trycatch #byte(0x4b) loadg.l #byte(0x44) aref2 #byte(0x17) box #byte(0x32) cadr #byte(0x24) argc #byte(0x3e) setg #byte(0x47) load0 #byte(0x15) nan? #byte(0x26) vector? #byte(0x2d) fixnum? #byte(0x29) loadc0 #byte(0x11) loada0 #byte(0x0) div0 #byte(0x3b) keyargs #byte(0x1f) call #byte(0x5) loada.l #byte(0x45) sub2 #byte(0x4e) add2 #byte(0x1d) loadc.l #byte(0x46) loadc #byte(0x9) builtin? #byte(0x2b) set-car! #byte(0x2f) vargc.l #byte(0x50) ret #byte(0xa) loadi8 #byte(0x42) tapply #byte(0x4d) loadvoid #byte(0x19) loada1 #byte(0x1) shift #byte(0x2e) atom? #byte(0x18) cdr #byte(0xd) brne.l #byte(0x53) / #byte(0x3a) equal? #byte(0x34) apply #byte(0x36) dup #byte(0xb) loadt #byte(0x14) jmp.l #byte(0x30) = #byte(0x3c) not #byte(0x23) set-cdr! #byte(0x1e) eq? #byte(0x21) * #byte(0x39) load1 #byte(0x1b) bound? #byte(0x2a) function? #byte(0x2c) box.l #byte(0x56) < #byte(0x1c) brnn.l #byte(0x54) jmp #byte(0x10) loadv #byte(0x2) for #byte(0x4c) dummy_eof #byte(0x58) + #byte(0x37) brne #byte(0x13) argc.l #byte(0x4f) compare #byte(0x3d) brn #byte(0x3) neg #byte(0x25) number? #byte(0x28) loadv.l #byte(0x43) vargc #byte(0x4a) brbound #byte(0x27) vector #byte(0x3f) loadc1 #byte(0x16) setg.l #byte(0x48) cons? #byte(0x12) aref #byte(0x55) symbol? #byte(0x22) aset! #byte(0x40) car #byte(0xc) cons #byte(0x20) tcall.l #byte(0x52) - #byte(0x38) brn.l #byte(0x31) optargs #byte(0x57) closure #byte(0xe) pop #byte(0x4) eqv? #byte(0x33) list #byte(0x35) seta #byte(0xf) seta.l #byte(0x49) brnn #byte(0x1a) loadnil #byte(0x41) loadg #byte(0x7) loada #byte(0x8) tcall #byte(0x6))
- __init_globals #fn("n07021d37022@402384w4^147025d;350426;J50427w8429w:47;w<47=w>47?w@:" #(*os-name*+ __finish #fn("n120210>17262:" #(#fn(for-each)+ #fn("n10A61:" #()) *exit-hooks*) __finish)+ __init_globals #fn("n07021d37022@402384w4^147025d;350426;J50427w8429w:4qw;47<w=47>w?47@wA:" #(*os-name* "macos" #fn("n0702161:" #(princ "\e[0m\e[1m#;> \e[0m")) #fn("n0702161:" #(princ "#;> ")) *prompt* "dos" "\\" "/" *directory-separator* "\n" *linefeed*- *stdout* *output-stream* *stdin* *input-stream* *stderr* *error-stream*) __init_globals)
+ *exit-hooks* *stdout* *output-stream* *stdin* *input-stream* *stderr* *error-stream*) __init_globals)
__rcscript #fn("n0708421c360q@T08422c37023@G08424c3=07526514q@4027^184;3904288451708622c37029@402:^185;3=042;857<8653873B02=87513907>8761:q:" #(*os-name*"unknown" "plan9" "home" "macos" princ "\e]0;StreetLISP v0.999\a" "HOME" #fn(os-getenv) "lib/slrc"
".slrc" #fn(string) *directory-separator* #fn(path-exists?) load) __rcscript)
@@ -70,8 +72,9 @@
__script
__rcscript repl
#fn(exit)) __start)
- abs #fn("n10EL23500U:0:" #() abs) any- #fn("n21B;3D0401<51;J:047001=62:" #(any) any) arg-counts #table(bound? 1 function? 1 symbol? 1 car 1 cons 2 cadr 1 nan? 1 for 3 fixnum? 1 vector? 1 cdr 1 atom? 1 div0 2 equal? 2 eqv? 2 compare 2 not 1 number? 1 set-cdr! 2 eq? 2 builtin? 1 cons? 1 set-car! 2)+ abs #fn("n10EL23500U:0:" #() abs) add-exit-hook+ #fn("n1070Pw047160:" #(*exit-hooks* void) add-exit-hook) any #fn("n21B;3D0401<51;J:047001=62:" #(any) any)+ arg-counts #table(bound? 1 function? 1 symbol? 1 car 1 cons 2 cadr 1 nan? 1 for 3 fixnum? 1 vector? 1 cdr 1 atom? 1 div0 2 equal? 2 eqv? 2 compare 2 not 1 number? 1 set-cdr! 2 eq? 2 builtin? 1 cons? 1 set-car! 2)
argc-error #fn("n2702102211Kl237023@402465:" #(error "compile error: " " expects " " argument."" arguments.") argc-error)
array? #fn("n10];JF042005185B;390485<21Q:" #(#fn(typeof) array) array?) assoc@@ -292,18 +295,17 @@
#fn("n10B3p070051r2A<85F52i29286G3;093<FKM61:928685p49286KM71051p494<0=61:92:" #(caarcdar)))) #fn(length)) make-perfect-hash-table)
make-system-image #fn("n120021222354247576Dw54Dw64278788>2288685>22989>1{89504:" #(#fn(file)- :write :create :truncate (*linefeed* *directory-separator* *argv* that *print-pretty*
- *print-width* *print-readably* *print-level* *print-length*
- *os-name* *interactive* *prompt* *os-version* procedure?
- top-level-bound?) *print-pretty* *print-readably* #fn("n0Aw04Fw1:" #(*print-pretty*- *print-readably*)) #fn("n07021A>17223505152742576842577845253f22885F52429F7:52^1^142;F61:" #(filter- #fn("n10Z;3u0420051S;3j0421051[S;JC0422051222105151dS;3I04230A52S;3=04242105151S:" #(#fn(constant?)- #fn(top-level-value)
- #fn(string)
- #fn(memq)
- #fn(iostream?)))
- simple-sort #fn(environment) nconc #fn(map) list top-level-value #fn(write)
- #fn(io-write) *linefeed* #fn(io-close))) #fn("n1A50420061:" #(#fn(raise)))) make-system-image)+ :write :create :truncate (*linefeed* *directory-separator* *argv* that *exit-hooks*
+ *print-pretty* *print-width* *print-readably* *print-level*
+ *print-length* *os-name* *interactive* *prompt* *os-version*
+ procedure? top-level-bound?) *print-pretty* *print-readably*
+ #fn("n0Aw04Fw1:" #(*print-pretty* *print-readably*))+ #fn("n07021A>17223505152742576842577845253f22885F52429F7:52^1^142;F61:" #(filter #fn("n10Z;3u0420051S;3j0421051[S;JC0422051222105151dS;3I04230A52S;3=04242105151S:" #(#fn(constant?)+ #fn(top-level-value) #fn(string) #fn(memq) #fn(iostream?))) simple-sort #fn(environment) nconc #fn(map)
+ list top-level-value #fn(write)
+ #fn(io-write)
+ *linefeed* #fn(io-close)))
+ #fn("n1A50420061:" #(#fn(raise)))) make-system-image) map! #fn("n21I1B3B04101<51_41=?1@\x1d/4:" #() map!) map-int #fn("n2701E52340q:0E51qPqb78786_4K7115122870>2|486:" #(<= 1- #fn("n1A<F051qPN4AA<=_:" #())) map-int) max #fn("z113;070210163:0:" #(foldl #fn("n201L23401:0:" #())) max) member--- a/src/sl.c
+++ b/src/sl.c
@@ -70,8 +70,11 @@
_Noreturn void
sl_exit(int status)
{- slg.exiting = true;
- sl_gc(false);
+ if(!slg.exiting){+ slg.exiting = true;
+ sl_applyn(1, symbol_value(symbol("__finish", false)), fixnum(status));+ sl_gc(false);
+ }
exit(status);
}
--- a/src/system.lsp
+++ b/src/system.lsp
@@ -1130,7 +1130,7 @@
(def (make-system-image fname)
(let ((f (file fname :write :create :truncate))
- (excludes '(*linefeed* *directory-separator* *argv* that
+ (excludes '(*linefeed* *directory-separator* *argv* that *exit-hooks*
*print-pretty* *print-width* *print-readably*
*print-level* *print-length* *os-name* *interactive*
*prompt* *os-version* procedure? top-level-bound?)))
@@ -1161,9 +1161,10 @@
Default function prints \"#;> \"." defprompt))
(set! *directory-separator* (or (and (equal? *os-name* "dos") "\\") "/"))
(set! *linefeed* "\n")
+ (set! *exit-hooks* nil)
(set! *output-stream* *stdout*)
- (set! *input-stream* *stdin*)
- (set! *error-stream* *stderr*))
+ (set! *input-stream* *stdin*)
+ (set! *error-stream* *stderr*))
(def (__script fname)
(trycatch (load fname)
@@ -1195,3 +1196,15 @@
(__rcscript)
(repl)))
(exit 0))
+
+(def (add-exit-hook fun)
+ "Puts an one-argument function on top of the list of exit hooks.
+On shutdown each exit hook is called with the exit status as a single
+argument, which is (usually) 0 on success and any other number on
+error."
+ (set! *exit-hooks* (cons fun *exit-hooks*))
+ (void))
+
+(def (__finish status)
+ "A function called right before exit by the VM."
+ (for-each (λ (f) (f status)) *exit-hooks*))