s9/000755 001751 001751 00000000000 13201116666 011023 5ustar00nmhnmh000000 000000 s9/TODO000644 001751 001751 00000000243 12751066245 011520 0ustar00nmhnmh000000 000000 - Upgrade to S9core Mk II probably broke the Plan 9 extension Please submit patches! - macro tests - EDOC: handle white space in block comments properly s9/_csums000644 001751 001751 00000041657 13201116647 012253 0ustar00nmhnmh000000 000000 49781 1 ./TODO 62833 94 ./s9.c 20304 1 ./ABOUT 160 35 ./s9.scm 60363 15 ./s9core.h 10174 19 ./s9.1.txt 32621 2 ./LICENSE 41089 38 ./contrib/format.scm 10781 11 ./contrib/format.txt 39931 9 ./contrib/format-test.scm 44960 9 ./contrib/prolog.scm 3185 22 ./contrib/pretty-print.scm 13964 3 ./contrib/string-locate.scm 61543 5 ./contrib/help.scm 15950 5 ./contrib/draw-tree.scm 54266 2 ./contrib/prolog-test.scm 17877 2 ./contrib/zebra.scm 51837 18 ./contrib/s9sos.scm 61572 29 ./contrib/s9sos.txt 52885 24 ./contrib/scm2html.scm 64650 3 ./contrib/scheme.css 48908 16 ./contrib/c2html.scm 54339 1 ./contrib/ccode.css 63279 9 ./contrib/S9Book 8463 9 ./contrib/S9Book-bw 20033 3 ./contrib/bottles.scm 35641 2 ./contrib/queens.scm 43736 1 ./lib/count.scm 27805 1 ./lib/depth.scm 5762 1 ./lib/filter.scm 4835 1 ./lib/flatten.scm 11948 2 ./lib/iota.scm 25830 1 ./lib/mergesort.scm 8266 1 ./lib/partition.scm 24832 1 ./lib/quicksort.scm 13995 2 ./lib/remove.scm 19981 1 ./lib/replace.scm 31321 1 ./lib/substitute.scm 21205 1 ./lib/read-line.scm 45215 1 ./lib/explode.scm 24675 1 ./lib/implode.scm 38067 2 ./lib/exists.scm 14627 2 ./lib/factor.scm 13612 1 ./lib/factorial.scm 37089 2 ./lib/for-all.scm 23926 1 ./lib/hyper.scm 13019 1 ./lib/sum.scm 5224 1 ./lib/integer-sqrt.scm 5374 2 ./lib/combine.scm 46296 3 ./lib/hof.scm 28038 2 ./lib/make-partitions.scm 44014 1 ./lib/list-to-set.scm 53006 1 ./lib/intersection.scm 16161 1 ./lib/transpose.scm 20808 1 ./lib/union.scm 61430 15 ./lib/regex.scm 65224 2 ./lib/string-split.scm 43287 11 ./lib/read-from-string.scm 31046 4 ./lib/write-to-string.scm 49558 6 ./lib/package.scm 28391 8 ./lib/amk.scm 36907 7 ./lib/symbols.scm 59228 7 ./lib/records.scm 6244 2 ./lib/cond-expand.scm 31781 3 ./lib/letrecstar.scm 48815 6 ./lib/programp.scm 57409 3 ./lib/fluid-let.scm 56188 1 ./lib/read-file.scm 28219 6 ./lib/bitwise-ops.scm 44944 2 ./lib/fluid-let-sr.scm 8166 3 ./lib/keyword-value.scm 22306 10 ./lib/matcher.scm 14120 1 ./lib/string-case.scm 30532 1 ./lib/unsort.scm 61401 2 ./lib/string-parse.scm 24584 1 ./lib/string-unsplit.scm 8681 1 ./lib/sieve.scm 11534 1 ./lib/displaystar.scm 33750 2 ./lib/list-tools.scm 49990 1 ./lib/syntax-extensions.scm 45653 1 ./lib/math-tools.scm 4484 1 ./lib/set-tools.scm 13579 1 ./lib/io-tools.scm 60052 1 ./lib/string-tools.scm 55783 6 ./lib/streams.scm 37266 2 ./lib/string-find.scm 26972 2 ./lib/string-translate.scm 16498 2 ./lib/string-digest.scm 41289 2 ./lib/string-find-last.scm 33166 3 ./lib/name-to-file-name.scm 43854 3 ./lib/and-letstar.scm 39842 9 ./lib/syntax-rules.scm 33279 3 ./lib/string-position.scm 1805 3 ./lib/string-last-position.scm 9448 4 ./lib/split-url.scm 55519 2 ./lib/url-decode.scm 30551 5 ./lib/tagbody.scm 8299 2 ./lib/vector-map.scm 33561 1 ./lib/string-scan.scm 51579 1 ./lib/sort.scm 48168 1 ./lib/string-map.scm 6973 1 ./lib/sublist.scm 50661 1 ./lib/subvector.scm 59710 1 ./lib/vector-tools.scm 56532 1 ./lib/letcc.scm 26439 2 ./lib/threads.scm 35936 2 ./lib/catch.scm 16765 9 ./lib/array.scm 36101 3 ./lib/amb.scm 4112 2 ./lib/position.scm 26223 1 ./lib/set-difference.scm 22678 2 ./lib/simple-modules.scm 48235 1 ./lib/adjoin.scm 33638 1 ./lib/subsetp.scm 22199 2 ./lib/tree-copy.scm 9327 1 ./lib/equal-cip.scm 12227 2 ./lib/type-case.scm 15174 1 ./lib/assp.scm 20264 1 ./lib/memp.scm 65105 7 ./lib/t-sort.scm 24798 1 ./lib/graph-tools.scm 56010 1 ./lib/tree-equalp.scm 29345 1 ./lib/data-structures.scm 25990 3 ./lib/permute.scm 13988 2 ./lib/random.scm 31507 1 ./lib/split.scm 52795 2 ./lib/merge.scm 50840 2 ./lib/integer-to-binary-string.scm 171 1 ./lib/id.scm 21369 2 ./lib/memoize.scm 51102 2 ./lib/queue.scm 38369 2 ./lib/duplicates.scm 24289 1 ./lib/when.scm 9045 2 ./lib/while.scm 11640 7 ./lib/hash-table.scm 13516 1 ./lib/_template 64602 1 ./lib/tree-map.scm 56265 7 ./lib/char-canvas.scm 50138 1 ./lib/listq.scm 65490 2 ./lib/appendb.scm 39888 1 ./lib/random-sort.scm 23407 1 ./lib/string-reverse.scm 36365 8 ./lib/rb-tree.scm 15405 1 ./lib/list-copy.scm 51316 3 ./lib/setters.scm 33646 1 ./lib/htmlify-char.scm 39499 2 ./lib/loutify-char.scm 45523 2 ./lib/string-expand.scm 55649 4 ./lib/bitops.scm 3992 1 ./lib/string-prefixeqp.scm 36310 3 ./lib/get-prop.scm 61693 7 ./lib/define-structure.scm 61912 1 ./lib/group.scm 18566 1 ./lib/take.scm 58979 1 ./lib/choose.scm 46739 4 ./lib/char-plot.scm 2895 2 ./lib/collect.scm 58798 1 ./lib/cdf.scm 33407 1 ./lib/erf.scm 990 1 ./lib/mean.scm 14057 1 ./lib/median.scm 63257 1 ./lib/mode.scm 8317 1 ./lib/ndf.scm 37303 2 ./lib/quartile.scm 39013 1 ./lib/range.scm 46078 1 ./lib/stddev.scm 5731 1 ./lib/variance.scm 49659 1 ./lib/stat-tools.scm 43336 1 ./lib/basename.scm 52692 2 ./lib/dirname.scm 40694 5 ./lib/format-time.scm 34058 1 ./lib/leap-yearp.scm 58592 2 ./lib/proper-timep.scm 32310 3 ./lib/time-ops.scm 56450 2 ./lib/time-to-unix-time.scm 392 3 ./lib/unix-time-to-time.scm 28483 13 ./ext/curses/curses.c 58898 3 ./ext/curses/curses.scm 21303 6 ./ext/curses/get-line.scm 1058 30 ./ext/sys-unix/unix.c 41312 14 ./ext/sys-unix/unix.scm 27857 1 ./ext/sys-unix/append-to-output-file.scm 53196 1 ./ext/sys-unix/find-help-path.scm 35624 5 ./ext/sys-unix/find-help.scm 31111 1 ./ext/sys-unix/flush-output-port.scm 27388 4 ./ext/sys-unix/inet-server.scm 38854 2 ./ext/sys-unix/mode-to-string.scm 25459 10 ./ext/sys-unix/parse-optionsb.scm 23432 8 ./ext/sys-unix/runtime-stats.scm 26326 1 ./ext/sys-unix/search-path.scm 26074 2 ./ext/sys-unix/spawn-command.scm 39640 2 ./ext/sys-unix/spawn-shell-command.scm 28668 2 ./ext/sys-unix/standard-error.scm 4185 3 ./ext/sys-unix/time.scm 61462 1 ./ext/sys-unix/unix-tools.scm 64649 28 ./ext/sys-plan9/plan9.c 39461 1 ./ext/sys-plan9/s9-ffi.h 25212 1 ./ext/sys-plan9/plan9-tools.scm 9421 2 ./ext/sys-plan9/s9-ffi.c 11257 4 ./ext/sys-plan9/plan9.scm 1815 1 ./ext/sys-plan9/util.scm 60490 3 ./ext/csv/csv.c 23192 1 ./ext/csv/csv.scm 64266 2 ./help/help 1087 1 ./help/not 49789 5 ./help/eqvp 47200 1 ./help/delete-file 55741 1 ./help/booleanp 10977 2 ./help/eqp 33160 1 ./help/equalp 24821 1 ./help/pairp 65532 1 ./help/cons 33705 1 ./help/car 47732 1 ./help/cdr 54906 1 ./help/set-carb 42411 1 ./help/set-cdrb 2048 1 ./help/caar 11380 1 ./help/nullp 38350 1 ./help/listp 19890 1 ./help/list 10843 1 ./help/append 30149 1 ./help/length 54573 1 ./help/reverse 60876 1 ./help/list-tail 59198 1 ./help/list-ref 47079 1 ./help/memq 39640 2 ./help/assq 25300 1 ./help/symbolp 64465 1 ./help/symbol-to-string 24425 1 ./help/string-to-symbol 43533 1 ./help/numberp 25596 1 ./help/eq 31064 1 ./help/zerop 22847 1 ./help/max 64604 1 ./help/plus 13408 1 ./help/letstar 21834 1 ./help/minus 4692 1 ./help/abs 56423 1 ./help/quotient 29411 1 ./help/gcd 53596 1 ./help/expt 3657 1 ./help/number-to-string 42584 1 ./help/string-to-number 61649 1 ./help/charp 29001 1 ./help/chareqp 41310 1 ./help/char-cieqp 40142 1 ./help/stringp 53873 1 ./help/char-alphabeticp 21946 1 ./help/char-to-integer 57003 1 ./help/char-upcase 33290 1 ./help/make-string 45573 1 ./help/string 47187 1 ./help/string-length 12449 1 ./help/string-ref 44210 1 ./help/string-setb 46514 1 ./help/stringeqp 30198 2 ./help/stringltp 41848 1 ./help/substring 62560 1 ./help/string-append 38006 1 ./help/string-to-list 63175 1 ./help/string-copy 63259 1 ./help/string-fillb 27804 1 ./help/vectorp 12005 1 ./help/make-vector 19214 1 ./help/vector 4995 1 ./help/vector-length 58628 1 ./help/vector-ref 19874 1 ./help/vector-setb 53576 1 ./help/vector-to-list 54487 1 ./help/vector-fillb 55423 1 ./help/procedurep 19435 1 ./help/apply 45554 1 ./help/map 45036 1 ./help/for-each 6464 3 ./help/force 16145 1 ./help/call-with-input-file 12476 1 ./help/input-portp 50753 1 ./help/current-input-port 64337 1 ./help/with-input-from-file 41681 1 ./help/open-input-file 52017 1 ./help/open-output-file 27230 1 ./help/close-input-port 24043 2 ./help/read 4656 1 ./help/read-char 61989 1 ./help/peek-char 55133 1 ./help/eof-objectp 7144 1 ./help/write 3055 1 ./help/display 24725 1 ./help/newline 46692 1 ./help/write-char 60477 1 ./help/load 64064 1 ./help/file-existsp 60754 1 ./help/fold-left 21457 1 ./help/fold-right 23514 1 ./help/gensym 20869 1 ./help/load-from-library 36764 1 ./help/locate-file 16854 1 ./help/print 8822 1 ./help/set-input-portb 57333 1 ./help/symbols 18087 1 ./help/begin 54590 2 ./help/case 24726 2 ./help/cond 21589 3 ./help/define 15373 2 ./help/do 11764 1 ./help/if 63336 3 ./help/lambda 39198 2 ./help/let 13493 3 ./help/quasiquote 46083 2 ./help/letrec 4460 1 ./help/or 63168 1 ./help/and 64155 2 ./help/quote 16669 1 ./help/setb 34805 2 ./help/starstar 43399 3 ./help/define-syntax 3499 4 ./help/syntax-rules 52971 4 ./help/bitwise-and 40947 3 ./help/complement 64410 1 ./help/cond-expand 39984 1 ./help/count 58766 1 ./help/depth 4445 1 ./help/draw-tree 16601 1 ./help/exists 62405 1 ./help/explode 41826 1 ./help/factor 14451 1 ./help/factorial 4378 1 ./help/filter 55037 1 ./help/flatten 51516 1 ./help/fluid-let 35785 1 ./help/for-all 56125 11 ./help/format 65279 1 ./help/hyper 61892 1 ./help/implode 31530 1 ./help/integer-sqrt 43971 1 ./help/intersection 61012 1 ./help/iota 8662 1 ./help/list-to-set 48623 3 ./help/make-hash-table 21352 1 ./help/make-partitions 11796 1 ./help/mergesort 19204 2 ./help/make-rbt 49995 1 ./help/module 59840 1 ./help/partition 11943 3 ./help/pretty-print 26445 1 ./help/programp 26273 3 ./help/record 18901 2 ./help/prolog 50993 1 ./help/sum 4897 1 ./help/quicksort 33968 4 ./help/re-comp 62920 1 ./help/read-file 26079 2 ./help/read-from-string 48655 1 ./help/read-line 52832 1 ./help/remove 34044 1 ./help/replace 29281 1 ./help/runstar 64340 2 ./help/string-find 57290 1 ./help/string-split 60153 1 ./help/union 10295 1 ./help/substitute 17675 1 ./help/transpose 5658 1 ./help/write-to-string 24173 1 ./help/zebra 9700 1 ./help/string-upcase 45003 3 ./help/define-matcher 7381 1 ./help/sqrt 43505 1 ./help/string-parse 1178 1 ./help/format-time 60975 1 ./help/unsort 21151 1 ./help/error 2885 1 ./help/require-extension 11262 2 ./help/letrecstar 57445 1 ./help/string-digest 31643 1 ./help/sieve 3753 1 ./help/time-to-unix-time 30777 1 ./help/unix-time-to-time 18439 1 ./help/basename 51970 1 ./help/string-unsplit 1652 1 ./help/dirname 47755 1 ./help/proper-timep 15725 1 ./help/leap-yearp 17895 1 ./help/eval 33576 1 ./help/displaystar 47600 1 ./help/string-locate 43585 2 ./help/string-find-last 41012 4 ./help/make-stream 50247 2 ./help/name-to-file-name 44140 1 ./help/string-scan 64617 1 ./help/string-translate 14436 2 ./help/and-letstar 35301 1 ./help/sort 43632 2 ./help/string-position 12366 2 ./help/string-last-position 15593 2 ./help/split-url 16865 1 ./help/url-decode 28818 1 ./help/r4rs-procedures 64087 5 ./help/define-class 55407 1 ./help/vector-map 42640 1 ./help/string-map 10619 1 ./help/subvector 2477 1 ./help/sublist 51013 4 ./help/call-with-current-continuation 11936 1 ./help/letslashcc 21243 1 ./help/thread-create 39694 2 ./help/macro-expand 54021 1 ./help/tagbody 45087 3 ./help/define-structure 57292 1 ./help/catch 65438 3 ./help/make-array 37337 2 ./help/amb 11981 1 ./help/position 19553 1 ./help/set-difference 15780 1 ./help/adjoin 29335 1 ./help/subsetp 12823 1 ./help/equal-cip 36613 1 ./help/type-case 238 1 ./help/memp 34943 1 ./help/assp 32961 4 ./help/t-sort 7925 1 ./help/tree-equalp 42991 1 ./help/permute 12887 1 ./help/combine 53779 1 ./help/random 64901 1 ./help/split 14511 1 ./help/merge 36062 1 ./help/integer-to-binary-string 62073 1 ./help/id 21367 2 ./help/memoize 51507 1 ./help/duplicates 42702 1 ./help/exp 41932 2 ./help/queue 9890 1 ./help/while 23741 1 ./help/when 30867 1 ./help/keyword-value 38838 1 ./help/reverseb 57235 1 ./help/stats 20863 1 ./help/void 46806 1 ./help/undefined 57151 1 ./help/tree-map 21316 2 ./help/pushb 6741 2 ./help/package 40581 1 ./help/system 37827 3 ./help/make-canvas 25068 1 ./help/listq 57005 1 ./help/appendb 47262 1 ./help/random-sort 9412 2 ./help/floor 38169 1 ./help/exactp 53654 1 ./help/exponent 23426 1 ./help/exact-to-inexact 22290 1 ./help/string-reverse 14843 2 ./help/c2html 30613 3 ./help/scm2html 8360 1 ./help/group 39591 1 ./help/loutify-char 10656 1 ./help/htmlify-char 13256 1 ./help/string-expand 6752 2 ./help/bit-op 2072 3 ./help/bit0 22245 2 ./help/time-add 17943 1 ./help/cdf 59170 2 ./help/get-line 30346 1 ./help/string-prefixeqp 46909 2 ./help/get-prop 57957 1 ./help/data-structures 30052 1 ./help/graph-tools 50711 1 ./help/syntax-extensions 14312 1 ./help/tree-copy 58120 1 ./help/list-copy 64983 1 ./help/take 1468 1 ./help/choose 20110 2 ./help/char-plot 1880 1 ./help/ndf 48272 1 ./help/vector-append 14589 1 ./help/nase 64685 1 ./help/vector-copy 26233 2 ./help/curses/curs_addch 58199 2 ./help/curses/curs_attroff 14692 4 ./help/curses/curs_cbreak 7059 1 ./help/curses/curs_clear 18676 1 ./help/curses/curs_color-set 568 1 ./help/curses/curs_cursoff 61683 2 ./help/curses/curs_delch 12648 1 ./help/curses/curs_endwin 45545 3 ./help/curses/curs_flushinp 59170 2 ./help/curses/get-line 20207 1 ./help/environ 48804 1 ./help/queens 24435 1 ./help/collect 3086 1 ./help/argv 27151 8 ./help/INDEX 21889 1 ./help/bottles 24804 1 ./help/mean 9721 1 ./help/quartile 60192 1 ./help/median 19456 1 ./help/mode 21950 1 ./help/range 42447 1 ./help/erf 46554 1 ./help/stddev 48285 1 ./help/variance 52402 1 ./help/stat-tools 64211 1 ./help/sys-unix/sys_access 57080 1 ./help/sys-unix/sys_catch-errors 40672 1 ./help/sys-unix/sys_chdir 51898 2 ./help/sys-unix/sys_chmod 8 1 ./help/sys-unix/sys_chown 37925 1 ./help/sys-unix/sys_command-line 42214 1 ./help/sys-unix/sys_dup 45656 1 ./help/sys-unix/sys_errno 44639 1 ./help/sys-unix/sys_execv 40127 1 ./help/sys-unix/sys_exit 39622 1 ./help/sys-unix/sys_fileno 23257 1 ./help/sys-unix/sys_flush 39525 1 ./help/sys-unix/sys_fork 34058 1 ./help/sys-unix/sys_get-magic-value 40362 1 ./help/sys-unix/sys_getcwd 33322 1 ./help/sys-unix/sys_getenv 17943 1 ./help/sys-unix/sys_getpgid 62953 1 ./help/sys-unix/sys_getgrnam 3413 1 ./help/sys-unix/sys_getpid 2018 1 ./help/sys-unix/sys_getpwent 34379 1 ./help/sys-unix/sys_getpwnam 27041 1 ./help/sys-unix/sys_gettimeofday 18147 1 ./help/sys-unix/sys_getuid 34912 1 ./help/sys-unix/sys_group-name 36642 1 ./help/sys-unix/append-to-output-file 52911 1 ./help/sys-unix/find-help-path 64593 1 ./help/sys-unix/find-help 30107 1 ./help/sys-unix/flush-output-port 12997 1 ./help/sys-unix/sys_kill 28002 1 ./help/sys-unix/sys_link 35577 1 ./help/sys-unix/sys_lock 14750 1 ./help/sys-unix/sys_lseek 63956 1 ./help/sys-unix/sys_make-input-port 11282 1 ./help/sys-unix/sys_mkdir 41623 2 ./help/sys-unix/sys_open 23740 1 ./help/sys-unix/sys_pipe 24689 1 ./help/sys-unix/sys_read 64366 1 ./help/sys-unix/sys_readdir 6790 1 ./help/sys-unix/sys_readlink 46446 1 ./help/sys-unix/sys_rename 18025 1 ./help/sys-unix/sys_rmdir 25380 1 ./help/sys-unix/sys_select 40128 1 ./help/sys-unix/sys_setuid 12810 2 ./help/sys-unix/sys_stat 16454 1 ./help/sys-unix/time 50854 2 ./help/sys-unix/sys_stat-name 15841 2 ./help/sys-unix/sys_stat-regularp 36402 1 ./help/sys-unix/sys_strerror 23802 1 ./help/sys-unix/sys_symlink 17646 1 ./help/sys-unix/sys_system 50004 1 ./help/sys-unix/sys_umask 57019 1 ./help/sys-unix/sys_unlink 1107 1 ./help/sys-unix/sys_unlock 52659 1 ./help/sys-unix/sys_user-name 57349 1 ./help/sys-unix/sys_usleep 9510 1 ./help/sys-unix/sys_utimes 21996 1 ./help/sys-unix/sys_wait 24203 2 ./help/sys-unix/inet-server 11770 1 ./help/sys-unix/mode-to-string 46621 4 ./help/sys-unix/parse-optionsb 12440 3 ./help/sys-unix/runtime-stats 30565 1 ./help/sys-unix/search-path 42119 1 ./help/sys-unix/spawn-command 32572 1 ./help/sys-unix/spawn-shell-command 15102 1 ./help/sys-unix/standard-error-port 297 1 ./help/sys-unix/char-readyp 9601 1 ./help/sys-unix/sys_inet-connect 1686 1 ./help/sys-unix/sys_inet-getpeername 52834 2 ./help/sys-unix/sys_inet-listen 26606 1 ./help/sys-unix/unix-tools 7793 2 ./help/csv/csv_read 58997 1 ./help/sys-plan9/plan9-tools 12993 1 ./help/sys-plan9/util 37423 2 ./prog/c2html1.scm 37734 9 ./prog/s9resolve.scm 39328 3 ./prog/soccat.scm 62067 3 ./prog/htmlify.scm 53539 3 ./prog/dupes.scm 8808 3 ./prog/s9help.scm 20994 3 ./prog/scm2html1.scm 17543 19 ./prog/advgen.txt 37857 23 ./prog/advgen.scm 11646 1 ./prog/adventure.intro 58627 2 ./prog/scmpp.scm 33669 24 ./prog/adventure.adv 324 9 ./prog/s9hts.scm 5456 3 ./prog/cols.scm 10549 1 ./prog/edoc.css 23468 3 ./prog/s9symbols.scm 56910 56 ./prog/edoc.scm.edoc 3265 6 ./util/rpp.c 53688 1 ./util/rp_html 45662 63 ./util/test.scm 12249 29 ./util/libtest.scm 17652 2 ./util/libtest.sh 56724 1 ./util/dirhead 22793 11 ./util/descriptions 62845 1 ./util/dirtail 53266 4 ./util/srtest.scm 24997 10 ./util/make-html 64416 2 ./util/make-docs 7078 1 ./util/libhead 62845 1 ./util/libtail 37268 13 ./util/make-help-links 37064 4 ./util/stress-tests.tgz 53946 17 ./util/systest.scm 59998 2 ./util/check-descr.scm 40684 8 ./util/categories.html 7041 3 ./util/make-cats.scm 34829 45 ./util/realtest.scm 20795 1 ./util/pagetail 16595 1 ./util/pagehead 17354 2 ./util/procedures.scm 32994 2 ./util/blurb 20920 1 ./util/mktoc.sed 31056 3 ./util/book 48144 1 ./util/s9.rc 41741 13 ./util/fix-help-files 15382 8 ./README 64380 8 ./Makefile 48690 1 ./config.scm 43017 1 ./configure 49810 2 ./mkfile 11686 16 ./s9.1 757 66 ./s9core.c 61426 80 ./CHANGES 58782 71 ./s9core.txt 23988 8 ./s9import.h 23969 9 ./MASCOT.png 22085 2 ./README.s9core 55250 1 ./s9ext.h s9/s9.c000644 001751 001751 00000272234 13201114463 011525 0ustar00nmhnmh000000 000000 /* * Scheme 9 from Empty Space, Refactored * By Nils M Holm, 2007-2017 * In the public domain */ #define VERSION "2017-11-09" #include "s9core.h" #include "s9import.h" #include "s9ext.h" #ifdef unix #include #define handle_sigquit() signal(SIGQUIT, keyboard_quit) #define handle_sigterm() signal(SIGTERM, terminated) #define handle_sigint() signal(SIGINT, keyboard_interrupt) #endif #ifdef plan9 #define handle_sigquit() #define handle_sigterm() #define handle_sigint() notify(keyboard_interrupt) #endif #ifndef LIBRARY_PATH #ifdef unix #define LIBRARY_PATH \ "." \ ":lib" \ ":ext/unix" \ ":ext/csv" \ ":ext/curses" \ ":contrib" \ ":~/.s9fes" \ ":/usr/local/share/s9fes" #endif #ifdef plan9 #define LIBRARY_PATH \ "." \ ":lib" \ ":ext/csv" \ ":ext/plan9" \ ":contrib" \ ":~/lib/s9fes" #endif #endif #define TOKEN_LENGTH 1024 #define MAX_PORTS 32 #define MAX_IO_DEPTH 65536 /* Reduce on 16-bit systems! */ #define HASH_THRESHOLD 5 #define MAX_CALL_TRACE 5 /* * Evaluator states */ enum EVAL_STATES { EV_ATOM, /* Evaluating atom */ EV_ARGS, /* Evaluating argument list */ EV_BETA, /* Evaluating procedure body */ EV_IF_PRED, /* Evaluating predicate of IF */ EV_SET_VAL, /* Evaluating value of SET! and DEFINE */ EV_MACRO, /* Evaluating value of DEFINE-SYNTAX */ EV_BEGIN, /* Evaluating expressions of BEGIN */ EV_AND, /* Evaluating arguments of AND */ EV_OR, /* Evaluating arguments of OR */ EV_COND /* Evaluating clauses of COND */ }; /* * Binding structure */ #define make_binding(v, a) (cons((v), (a))) #define binding_box(x) (x) #define binding_value(x) (cdr(x)) #define box_value(x) (cdr(x)) /* * Internal specials */ #define RPAREN (USER_SPECIALS-1) #define RBRACK (USER_SPECIALS-2) #define DOT (USER_SPECIALS-3) /* * Globals */ static char S9magic[17]; static cell Stack_bottom; static cell State_stack; static cell Tmp_car, Tmp_cdr; static cell Tmp; static cell Program; static cell Environment; static cell Acc; static cell Apply_magic, Callcc_magic; static int Level; static int Load_level; static int Displaying; static cell Called_procedures[MAX_CALL_TRACE]; static int Proc_ptr; static cell File_list; static int Line_no; static int Opening_line; static cell Trace_list; static int Quiet_mode; static int Eval_stats; static counter Reductions; static volatile int Error_flag, Intr_flag; cell Argv; /* Short cuts for accessing predefined symbols */ static cell S_and, S_arguments, S_arrow, S_begin, S_cond, S_define, S_define_syntax, S_else, S_extensions, S_host_system, S_if, S_lambda, S_latest, S_library_path, S_loading, S_or, S_quasiquote, S_quote, S_set_b, S_unquote, S_unquote_splicing; /* * I/O */ #define readc_ci() tolower(readc()) /* * Type predicates */ #define special_form_p(n) \ ((n) == S_quote || \ (n) == S_begin || \ (n) == S_if || \ (n) == S_cond || \ (n) == S_and || \ (n) == S_or || \ (n) == S_lambda || \ (n) == S_set_b || \ (n) == S_define || \ (n) == S_define_syntax) #define auto_quoting_p(n) atom_p(n) /* * Rib structure */ #define rib_args(x) (car(x)) #define rib_append(x) (cadr(x)) #define rib_result(x) (caddr(x)) #define rib_source(x) (cdddr(x)) /* * Allocators */ #define save_state(v) (State_stack = cons3((v), State_stack, S9_ATOM_TAG)) /* * Error Handling */ void reset_tty(void) { #ifdef CURSES_RESET cell pp_curs_endwin(cell); pp_curs_endwin(NIL); #endif } void quit(int n) { reset_tty(); bye(n); } void print_form(cell n); void print_error_form(cell n) { set_printer_limit(50); print_form(n); set_printer_limit(0); } void print_calltrace(void) { int i, j; for (i=0; i= MAX_CALL_TRACE) i = 0; if (Called_procedures[i] != NIL) { prints(" "); print_form(Called_procedures[i]); } i++; } nl(); } cell error(char *msg, cell expr) { int oport; char buf[100]; if (Error_flag) return UNSPECIFIC; oport = output_port(); set_output_port(Quiet_mode? 2: 1); Error_flag = 1; prints("error: "); if (Load_level) { if (File_list != NIL) { print_form(car(File_list)); prints(": "); } sprintf(buf, "%d: ", Line_no); prints(buf); } prints(msg); if (expr != VOID) { prints(": "); Error_flag = 0; print_error_form(expr); Error_flag = 1; } nl(); print_calltrace(); set_output_port(oport); if (Quiet_mode) quit(1); return UNSPECIFIC; } /* * Reader */ cell read_form(int flags); cell read_list(int flags, int delim) { cell n, /* Node read */ m, /* List */ a; /* Used to append nodes to m */ int c; /* Member counter */ cell new; char badpair[] = "malformed pair"; char msg[80]; if (!Level) Opening_line = Line_no; if (++Level > MAX_IO_DEPTH) { error("reader: too many nested lists or vectors", VOID); return NIL; } m = cons3(NIL, NIL, flags); /* root */ save(m); a = NIL; c = 0; while (1) { if (Error_flag) { unsave(1); return NIL; } n = read_form(flags); if (n == END_OF_FILE) { if (Load_level) { unsave(1); return END_OF_FILE; } sprintf(msg, "missing ')', started in line %d", Opening_line); error(msg, VOID); } if (n == DOT) { if (c < 1) { error(badpair, VOID); continue; } n = read_form(flags); cdr(a) = n; if (n == delim || read_form(flags) != delim) { error(badpair, VOID); continue; } unsave(1); Level--; return m; } if (n == RPAREN || n == RBRACK) { if (n != delim) error(n == RPAREN? "list starting with `[' ended with `)'": "list starting with `(' ended with `]'", VOID); break; } if (a == NIL) a = m; /* First member: insert at root */ else a = cdr(a); /* Subsequent members: append */ car(a) = n; new = cons3(NIL, NIL, flags); /* Space for next member */ cdr(a) = new; c++; } Level--; if (a != NIL) cdr(a) = NIL; /* Remove trailing empty node */ unsave(1); return c? m: NIL; } cell quote(cell n, cell quotation) { cell q; q = cons(n, NIL); return cons(quotation, q); } int strcmp_ci(char *s1, char *s2) { int c1, c2; while (1) { c1 = tolower((int) *s1++); c2 = tolower((int) *s2++); if (!c1 || !c2 || c1 != c2) break; } return c1c2? 1: 0; } int memcmp_ci(char *s1, char *s2, int k) { int c1 = 0, c2 = 0; while (k--) { c1 = tolower((int) *s1++); c2 = tolower((int) *s2++); if (c1 != c2) break; } return c1c2? 1: 0; } /* Read a character literal. */ cell read_character(void) { char buf[10], msg[50]; int i, c = 0; /*LINT*/ for (i=0; i 0 && !isalpha(c)) break; buf[i] = c; } rejectc(c); buf[i] = 0; if (i == 0) c = ' '; else if (i == 1) c = buf[0]; else if (!strcmp_ci(buf, "space")) c = ' '; else if (!strcmp_ci(buf, "newline")) c = '\n'; else { sprintf(msg, "unknown character: #\\%s", buf); error(msg, VOID); c = 0; } return make_char(c); } /* Read a string literal. */ cell read_string(void) { char s[TOKEN_LENGTH+1]; cell n; int c, i, q; int inv; i = 0; q = 0; c = readc(); inv = 0; while (q || c != '"') { if (c == '\n') Line_no++; if (c == EOF) error("missing '\"' in string literal", VOID); if (Error_flag) break; if (i >= TOKEN_LENGTH-2) { error("string literal too long", VOID); i--; } if (q && c != '"' && c != '\\') { s[i++] = '\\'; inv = 1; } s[i] = c; q = !q && c == '\\'; if (!q) i++; c = readc(); } s[i] = 0; n = make_string(s, i); Tag[n] |= S9_CONST_TAG; if (inv) error("invalid escape sequence in string", n); return n; } #define separator(c) \ ((c) == ' ' || (c) == '\t' || (c) == '\n' || \ (c) == '\r' || (c) == '(' || (c) == ')' || \ (c) == ';' || (c) == '\'' || (c) == '`' || \ (c) == ',' || (c) == '"' || (c) == '[' || \ (c) == ']' || (c) == EOF) #define SYM_CHARS "!@$%^&*-/_+=~.?<>:" #define is_symbolic(c) \ (isalpha(c) || \ isdigit(c) || \ strchr(SYM_CHARS, (c))) cell funny_char(char *msg, int c) { char buf[128]; if (isprint(c)) return error(msg, make_char(c)); sprintf(buf, "%s, code", msg); return error(buf, make_integer(c)); } cell read_symbol_or_number(int c) { char s[TOKEN_LENGTH]; int i, funny = 0; i = 0; while (!separator(c)) { if (!is_symbolic(c)) funny = c; if (i >= TOKEN_LENGTH-2) { error("symbol too long", VOID); i--; } s[i] = c; i++; c = readc_ci(); } s[i] = 0; rejectc(c); if (funny) return funny_char("funny character in symbol", funny); if (string_numeric_p(s)) return string_to_number(s); if (!strcmp(s, "define-macro")) return S_define_syntax; return symbol_ref(s); } cell list_to_vector(cell m, char *msg, int flags) { cell n, vec; int k; cell *p; k = 0; for (n = m; n != NIL; n = cdr(n)) { if (atom_p(n)) return error(msg, m); k++; } vec = new_vec(T_VECTOR, k*sizeof(cell)); Tag[vec] |= flags; p = vector(vec); for (n = m; n != NIL; n = cdr(n)) { *p = car(n); p++; } return vec; } cell read_vector(void) { cell n; n = read_list(0, RPAREN); save(n); n = list_to_vector(n, "invalid vector syntax", S9_CONST_TAG); unsave(1); return n; } cell meta_command(void) { int c, cmd, i; cell n, cmdsym; char s[128]; cmd = readc_ci(); c = readc(); while (c == ' ') c = readc(); i = 0; while (c != '\n' && c != EOF) { if (i < sizeof(s) - 2) s[i++] = c; c = readc(); } rejectc(c); s[i] = 0; n = make_string(s, strlen(s)); n = i == 0? NIL: cons(n, NIL); switch (cmd) { case 'a': cmdsym = symbol_ref("apropos"); break; case 'h': cmdsym = symbol_ref("help"); break; case 'l': cmdsym = symbol_ref("load-from-library"); break; case 'q': cmdsym = symbol_ref("sys:exit"); break; default: prints(",a = apropos"); nl(); prints(",h = help"); nl(); prints(",l = load-from-library"); nl(); prints(",q = sys:exit"); nl(); return UNSPECIFIC; } return cons(cmdsym, n); } int block_comment(void) { int n, c, state = 0; for (n=1; n; ) { c = readc_ci(); switch (c) { case EOF: error("missing |#", VOID); return 0; case '|': switch (state) { case 1: n++; state = 0; break; default: state = -1; break; } break; case '#': switch (state) { case -1: n--; state = 0; break; default: state = 1; break; } break; case '\n': Line_no++; state = 0; break; default: state = 0; break; } } return readc_ci(); } int closing_paren(void) { int c = readc_ci(); rejectc(c); return c == ')'; } cell bignum_read(char *pre, int radix) { char digits[] = "0123456789abcdef"; char buf[100]; cell base, num; int c, s, p, nd; base = make_integer(radix); save(base); num = Zero; save(num); c = readc_ci(); s = 0; if (c == '-') { s = 1; c = readc_ci(); } else if (c == '+') { c = readc_ci(); } nd = 0; while (!separator(c)) { p = 0; while (digits[p] && digits[p] != c) p++; if (p >= radix) { sprintf(buf, "invalid digit in %s number", pre); unsave(2); return funny_char(buf, c); } num = bignum_multiply(num, base); car(Stack) = num; num = bignum_add(num, make_integer(p)); car(Stack) = num; nd++; c = readc_ci(); } unsave(2); if (!nd) { sprintf(buf, "digits expected after %s", pre); return error(buf, VOID); } rejectc(c); return s? bignum_negate(num): num; } cell read_real_number(int inexact) { cell n, m; int flags; char buf[50]; n = read_form(0); if (integer_p(n)) { if (!inexact) return n; flags = bignum_negative_p(n)? REAL_NEGATIVE: 0; m = bignum_abs(n); return S9_make_real(flags, 0, cdr(m)); } else if (real_p(n)) { if (inexact) return n; m = real_to_bignum(n); if (m == UNDEFINED) return error("#e: no exact representation for", n); return m; } sprintf(buf, "number expected after #%c, got", inexact? 'i': 'e'); return error(buf, n); } cell integer_argument(char *who, cell x) { cell n; char msg[100]; if (real_p(x)) { n = real_to_bignum(x); if (n == UNDEFINED) { sprintf(msg, "%s: expected integer, got", who); error(msg, x); return UNDEFINED; } return n; } return x; } /* Report unreadable object */ cell unreadable(void) { int c, i; char buf[TOKEN_LENGTH]; int d; strcpy(buf, "#<"); i = 2; while (1) { c = readc_ci(); if (c == '>' || c == '\n') { if (c == '\n') Line_no++; break; } if (i < TOKEN_LENGTH-2) buf[i++] = c; } buf[i++] = '>'; buf[i] = 0; d = Displaying; Displaying = 1; error("unreadable object", make_string(buf, i)); Displaying = d; return UNDEFINED; } cell read_form(int flags) { char buf[50]; int c, c2; c = readc_ci(); while (1) { /* Skip over spaces and comments */ while (c == ' ' || c == '\t' || c == '\n' || c == '\r') { if (c == '\n') Line_no++; if (Error_flag) return NIL; c = readc_ci(); } if (c == '#') { c = readc_ci(); if (c == '!') { /* ok */ } else if (c == '|') { c = block_comment(); continue; } else { rejectc(c); c = '#'; break; } } else if (c != ';') break; while (!Error_flag && c != '\n' && c != EOF) c = readc_ci(); if (Error_flag) return UNSPECIFIC; } if (c == EOF) return END_OF_FILE; if (Error_flag) return UNSPECIFIC; if (c == '(') { return read_list(flags, RPAREN); } else if (c == '[') { return read_list(flags, RBRACK); } else if (c == '\'' || c == '`') { cell n; if (closing_paren()) return error("missing form after \"'\" or \"`\"", VOID); Level++; n = quote(read_form(S9_CONST_TAG), c=='`'? S_quasiquote: S_quote); Level--; return n; } else if (c == ',') { if (closing_paren()) return error("missing form after \",\"", VOID); c = readc_ci(); if (c == '@') { return quote(read_form(0), S_unquote_splicing); } else { rejectc(c); if (!Level) return meta_command(); return quote(read_form(0), S_unquote); } } else if (c == '#') { c = readc_ci(); switch (c) { case 'f': return FALSE; case 't': return TRUE; case '\\': return read_character(); case '(': return read_vector(); case 'b': return bignum_read("#b", 2); case 'd': return bignum_read("#d", 10); case 'o': return bignum_read("#o", 8); case 'x': return bignum_read("#x", 16); case 'e': return read_real_number(0); case 'i': return read_real_number(1); case '<': return unreadable(); default: sprintf(buf, "unknown # syntax: #%c", c); return error(buf, VOID); } } else if (c == '"') { return read_string(); } else if (c == ')') { if (!Level) return error("unexpected ')'", VOID); return RPAREN; } else if (c == ']') { if (!Level) return error("unexpected ']'", VOID); return RBRACK; } else if (c == '.') { c2 = readc_ci(); rejectc(c2); if (separator(c2)) { if (!Level) return error("unexpected '.'", VOID); return DOT; } return read_symbol_or_number(c); } else if (is_symbolic(c)) { return read_symbol_or_number(c); } else { return funny_char("funny input character", c); } } cell xread(void) { Level = 0; return read_form(0); } cell xsread(char *s) { cell n; open_input_string(s); n = read_form(0); close_input_string(); return n; } /* * Printer */ char *ntoa(char *b, cell x, int w) { char buf[40]; int i = 0, neg = 0; char *p = &buf[sizeof(buf)-1]; if (x < 0) { x = -x; neg = 1; } *p = 0; while (x || i == 0) { i++; if (i >= sizeof(buf)-1) fatal("ntoa: number too big"); p--; *p = x % 10 + '0'; x = x / 10; } while (i < (w-neg) && i < sizeof(buf)-1) { i++; p--; *p = '0'; } if (neg) { if (i >= sizeof(buf)-1) fatal("ntoa: number too big"); p--; *p = '-'; } strcpy(b, p); return b; } /* Print bignum integer. */ int print_integer(cell n) { if (!integer_p(n)) return 0; print_bignum(n); return 1; } /* Print real number. */ int print_realnum(cell n) { if (!real_p(n)) return 0; print_real(n); return 1; } /* Print expressions of the form (QUOTE X) as 'X. */ int print_quoted(cell n) { if ( car(n) == S_quote && cdr(n) != NIL && cddr(n) == NIL ) { prints("'"); print_form(cadr(n)); return 1; } return 0; } int print_procedure(cell n) { if (function_p(n)) { prints("#"); return 1; } return 0; } int print_continuation(cell n) { if (continuation_p(n)) { prints("#"); return 1; } return 0; } int print_char(cell n) { char b[2]; int c; if (!char_p(n)) return 0; if (!Displaying) prints("#\\"); c = cadr(n); b[1] = 0; if (!Displaying && c == ' ') prints("space"); else if (!Displaying && c == '\n') prints("newline"); else { b[0] = c; prints(b); } return 1; } int print_string(cell n) { char b[2]; int k; char *s; if (!string_p(n)) return 0; if (!Displaying) prints("\""); s = string(n); k = string_len(n)-1; b[1] = 0; while (k) { b[0] = *s++; if (!Displaying && (b[0] == '"' || b[0] == '\\')) prints("\\"); prints(b); k--; } if (!Displaying) prints("\""); return 1; } int print_symbol(cell n) { char *s; if (!symbol_p(n)) return 0; s = symbol_name(n); prints(s); return 1; } int print_primitive(cell n) { S9_PRIM *p; if (!primitive_p(n)) return 0; prints("#name); prints(">"); return 1; } int print_syntax(cell n) { if (!syntax_p(n)) return 0; prints("#"); return 1; } int print_vector(cell n) { cell *p; int k; if (!vector_p(n)) return 0; prints("#("); p = vector(n); k = vector_len(n); while (k--) { print_form(*p++); if (k) prints(" "); } prints(")"); return 1; } int print_port(cell n) { char buf[100]; if (!input_port_p(n) && !output_port_p(n)) return 0; sprintf(buf, "#<%s-port %d>", input_port_p(n)? "input": "output", (int) port_no(n)); prints(buf); return 1; } void x_print_form(cell n, int depth) { if (depth > MAX_IO_DEPTH) { error("printer: too many nested lists or vectors", VOID); return; } if (n == NIL) { prints("()"); } else if (eof_p(n)) { prints("#"); } else if (n == FALSE) { prints("#f"); } else if (n == TRUE) { prints("#t"); } else if (undefined_p(n)) { prints("#"); } else if (unspecific_p(n)) { prints("#"); } else { if (print_char(n)) return; if (print_procedure(n)) return; if (print_continuation(n)) return; if (print_realnum(n)) return; if (print_integer(n)) return; if (print_primitive(n)) return; if (print_quoted(n)) return; if (print_string(n)) return; if (print_symbol(n)) return; if (print_syntax(n)) return; if (print_vector(n)) return; if (print_port(n)) return; prints("("); while (n != NIL) { if (Error_flag) return; if (printer_limit()) return; x_print_form(car(n), depth+1); if (Error_flag) return; n = cdr(n); if (n != NIL && atom_p(n)) { prints(" . "); x_print_form(n, depth+1); n = NIL; } if (n != NIL) prints(" "); } prints(")"); } } void print_form(cell n) { x_print_form(n, 0); } /* * Special Form Handlers */ int proper_list_p(cell n) { while (pair_p(n)) n = cdr(n); return n == NIL; } cell append_b(cell a, cell b) { cell p, last = NIL; if (a == NIL) return b; p = a; while (p != NIL) { if (atom_p(p)) fatal("append!: improper list"); last = p; p = cdr(p); } cdr(last) = b; return a; } int argument_list_p(cell n) { if (n == NIL || symbol_p(n)) return 1; if (atom_p(n)) return 0; while (pair_p(n)) { if (!symbol_p(car(n))) return 0; n = cdr(n); } return n == NIL || symbol_p(n); } #define hash(s, h) \ do { \ h = 0; \ while (*s) \ h = ((h<<5)+h) ^ *s++; \ } while (0) int hash_size(int n) { if (n < 5) return 5; if (n < 11) return 11; if (n < 23) return 23; if (n < 47) return 47; if (n < 97) return 97; if (n < 199) return 199; if (n < 499) return 499; if (n < 997) return 997; if (n < 9973) return 9973; return 19997; } void rehash(cell e) { unsigned int i; cell p, *v, new; unsigned int h, k = hash_size(length(e)); char *s; if (Program == NIL || k < HASH_THRESHOLD) return; new = new_vec(T_VECTOR, k * sizeof(cell)); car(e) = new; v = vector(car(e)); for (i=0; i= HASH_THRESHOLD) { save(e); rehash(rib); unsave(1); } return e; } cell try_hash(cell v, cell e) { cell *hv, p; unsigned int h, k; char *s; if (e == NIL || car(e) == NIL) return NIL; hv = vector(car(e)); k = vector_len(car(e)); s = symbol_name(v); hash(s, h); p = hv[h%k]; while (p != NIL) { if (caar(p) == v) return car(p); p = cdr(p); } return NIL; } cell lookup(cell v, cell env, int req) { cell e, n; while (env != NIL) { e = car(env); n = try_hash(v, e); if (n != NIL) return n; if (e != NIL) e = cdr(e); /* skip over hash slot */ while (e != NIL) { if (v == caar(e)) return car(e); e = cdr(e); } env = cdr(env); } if (!req) return NIL; if (special_form_p(v)) error("invalid syntax", v); else error("symbol not bound", v); return NIL; } cell too_few_args(cell n) { return error("too few arguments", n); } cell too_many_args(cell n) { return error("too many arguments", n); } /* Set up sequence for AND, BEGIN, OR. */ cell make_sequence(int state, cell neutral, cell x, int *pc, int *ps) { if (cdr(x) == NIL) { return neutral; } else if (cddr(x) == NIL) { *pc = 1; return cadr(x); } else { *pc = 2; *ps = state; save(cdr(x)); return cadr(x); } } #define sf_and(x, pc, ps) \ make_sequence(EV_AND, TRUE, x, pc, ps) #define sf_begin(x, pc, ps) \ make_sequence(EV_BEGIN, UNSPECIFIC, x, pc, ps) cell sf_cond(cell x, int *pc, int *ps) { cell clauses, p; clauses = cdr(x); p = clauses; while (p != NIL) { if (atom_p(car(p))) return error("cond: invalid syntax", car(p)); p = cdr(p); } if (clauses == NIL) return UNSPECIFIC; if (caar(clauses) == S_else && cdr(clauses) == NIL) { p = cons(TRUE, cdar(clauses)); clauses = cons(p, cdr(clauses)); } save(clauses); *pc = 2; *ps = EV_COND; return caar(clauses); } cell sf_if(cell x, int *pc, int *ps) { cell m, new; m = cdr(x); if (m == NIL || cdr(m) == NIL) return too_few_args(x); if (cddr(m) != NIL && cdddr(m) != NIL) return too_many_args(x); if (cddr(m) == NIL) { new = cons(UNSPECIFIC, NIL); cddr(m) = new; } save(m); *pc = 2; *ps = EV_IF_PRED; return car(m); } cell gensym(char *prefix); cell make_temporaries(cell x) { cell n, v; n = NIL; save(n); while (x != NIL) { v = gensym("g"); n = cons(v, n); car(Stack) = n; x = cdr(x); } unsave(1); return n; } /* * Return (begin (set! x1 t1) * ... * (set! xN tN)) */ cell make_assignments(cell x, cell t) { cell n, asg; n = NIL; save(n); while (x != NIL) { asg = cons(car(t), NIL); asg = cons(car(x), asg); asg = cons(S_set_b, asg); n = cons(asg, n); car(Stack) = n; x = cdr(x); t = cdr(t); } unsave(1); return cons(S_begin, n); } cell make_undefineds(cell x) { cell n; n = NIL; while (x != NIL) { n = cons(UNDEFINED, n); x = cdr(x); } return n; } /* Return ((lambda (v1 ...) * ((lambda (t1 ...) * (begin (set! v1 t1) * ... * body)) * a1 ...)) * # * ...) */ cell make_recursive_lambda(cell v, cell a, cell body) { cell t, n; t = make_temporaries(v); save(t); body = append_b(make_assignments(v, t), body); body = cons(body, NIL); n = cons(t, body); n = cons(S_lambda, n); n = cons(n, a); n = cons(n, NIL); n = cons(v, n); n = cons(S_lambda, n); save(n); n = cons(n, make_undefineds(v)); unsave(2); return n; } enum { VARS, VALS }; /* Extract variables or arguments from a set of DEFINEs. */ cell extract_from_defines(cell x, int part, cell *restp) { cell a, n, new; int k; a = NIL; while (x != NIL) { if (atom_p(x) || atom_p(car(x)) || caar(x) != S_define) break; n = car(x); if ( !proper_list_p(n) || (k = length(n)) < 3 || !argument_list_p(cadr(n)) || (symbol_p(cadr(n)) && k > 3) ) return error("define: invalid syntax", n); if (pair_p(cadr(n))) { /* (define (proc vars) ...) */ if (part == VARS) { a = cons(caadr(n), a); } else { a = cons(NIL, a); save(a); new = cons(cdadr(n), cddr(n)); new = cons(S_lambda, new); car(a) = new; unsave(1); } } else { a = cons(part==VARS? cadr(n): caddr(n), a); } x = cdr(x); } *restp = x; return a; } /* * Rewrite local DEFINEs using LAMBDA and SET!. * This is semantically equivalent to: * * (lambda () ---> (lambda () * (define v1 a1) (letrec ((v1 a1) * ... ...) * body) body)) */ cell resolve_local_defines(int x) { cell v, a, n, rest; a = extract_from_defines(x, VALS, &rest); if (Error_flag) return NIL; save(a); v = extract_from_defines(x, VARS, &rest); save(v); if (rest == NIL) rest = cons(UNSPECIFIC, NIL); save(rest); n = make_recursive_lambda(v, a, rest); unsave(3); return n; } cell sf_lambda(cell x) { cell n; int k; k = length(x); if (k < 3) return too_few_args(x); if (!argument_list_p(cadr(x))) return error("malformed argument list", cadr(x)); if (pair_p(caddr(x)) && caaddr(x) == S_define) n = resolve_local_defines(cddr(x)); else if (k > 3) n = cons(S_begin, cddr(x)); else n = caddr(x); n = cons(n, Environment); n = cons(cadr(x), n); return new_atom(T_FUNCTION, n); } cell sf_quote(cell x) { if (cdr(x) == NIL) return too_few_args(x); if (cddr(x) != NIL) return too_many_args(x); return cadr(x); } #define sf_or(x, pc, ps) \ make_sequence(EV_OR, FALSE, x, pc, ps) cell sf_set_b(cell x, int *pc, int *ps) { cell n; int k; k = length(x); if (k < 3) return too_few_args(x); if (k > 3) return too_many_args(x); if (!symbol_p(cadr(x))) return error("set!: expected symbol, got", cadr(x)); n = lookup(cadr(x), Environment, 1); if (Error_flag) return NIL; save(n); *pc = 2; *ps = EV_SET_VAL; return caddr(x); } cell find_local_variable(cell v, cell e) { if (e == NIL) return NIL; e = cdr(e); while (e != NIL) { if (v == caar(e)) return car(e); e = cdr(e); } return NIL; } cell sf_define(int syntax, cell x, int *pc, int *ps) { cell v, a, n, new; int k; if (car(State_stack) == EV_ARGS) return error(syntax? "define-syntax: invalid context": "define: invalid context", x); k = length(x); if (k < 3) return too_few_args(x); if (symbol_p(cadr(x)) && k > 3) return too_many_args(x); if (!argument_list_p(cadr(x))) return error(syntax? "define-syntax: expected argument list, got": "define: expected argument list, got", cadr(x)); if (!symbol_p(cadr(x))) { a = cddr(x); a = cons(cdadr(x), a); a = cons(S_lambda, a); save(a); n = caadr(x); } else { save(NIL); a = caddr(x); n = cadr(x); } v = find_local_variable(n, car(Environment)); if (v == NIL) { new = extend(n, UNDEFINED, car(Environment)); car(Environment) = new; v = cadar(Environment); } car(Stack) = binding_box(v); *pc = 2; if (syntax) *ps = EV_MACRO; else *ps = EV_SET_VAL; return a; } cell apply_special(cell x, int *pc, int *ps) { cell sf; sf = car(x); if (sf == S_quote) return sf_quote(x); else if (sf == S_if) return sf_if(x, pc, ps); else if (sf == S_and) return sf_and(x, pc, ps); else if (sf == S_or) return sf_or(x, pc, ps); else if (sf == S_cond) return sf_cond(x, pc, ps); else if (sf == S_begin) return sf_begin(x, pc, ps); else if (sf == S_lambda) return sf_lambda(x); else if (sf == S_set_b) return sf_set_b(x, pc, ps); else if (sf == S_define) return sf_define(0, x, pc, ps); else if (sf == S_define_syntax) return sf_define(1, x, pc, ps); else fatal("internal: unknown special form"); return UNSPECIFIC; } /* * Primitives */ cell pp_apply(cell x) { cell m, p, q, last; m = x; p = cdr(m); last = p; while (p != NIL) { last = p; p = cdr(p); } p = car(last); while (p != NIL) { if (atom_p(p)) return error("apply: improper argument list", car(last)); p = cdr(p); } if (cddr(m) == NIL) { p = cadr(m); } else { p = flat_copy(cdr(m), &q); q = p; while (cddr(q) != NIL) q = cdr(q); cdr(q) = car(last); } return cons(car(m), p); } cell pp_call_cc(cell x) { cell cc, n; cc = cons(Stack, NIL); cc = cons(Stack_bottom, cc); cc = cons(State_stack, cc); cc = cons(Environment, cc); cc = new_atom(T_CONTINUATION, cc); n = cons(cc, NIL); n = cons(car(x), n); return n; } cell resume(cell x) { cell cc; if (cdr(x) == NIL) return too_few_args(x); if (cddr(x) != NIL) return too_many_args(x); cc = cdar(x); Environment = car(cc); State_stack = cadr(cc); Stack_bottom = caddr(cc); Stack = cadddr(cc); return cadr(x); } cell pp_unquote(cell x) { return error("unquote: not in quasiquote context", VOID); } cell pp_unquote_splicing(cell x) { return error("unquote-splicing: not in quasiquote context", VOID); } /* * Predicates and Booleans */ cell pp_eq_p(cell x) { return car(x) == cadr(x)? TRUE: FALSE; } int eqv_p(cell a, cell b) { if (a == b) return 1; if (char_p(a) && char_p(b) && char_value(a) == char_value(b)) return 1; if (number_p(a) && number_p(b)) { if (real_p(a) != real_p(b)) return 0; return real_equal_p(a, b); } return a == b; } cell pp_eqv_p(cell x) { return eqv_p(car(x), cadr(x))? TRUE: FALSE; } cell pp_not(cell x) { return car(x) == FALSE? TRUE: FALSE; } cell pp_null_p(cell x) { return car(x) == NIL? TRUE: FALSE; } /* * Pairs and Lists */ cell pp_append2(cell x) { cell new, n, p, a, *pa; if (car(x) == NIL) return cadr(x); if (cadr(x) == NIL) { if (pair_p(car(x))) return car(x); else return error("append2: expected list, got", car(x)); } a = n = cons(NIL, NIL); pa = &a; save(n); for (p = car(x); p != NIL; p = cdr(p)) { if (!pair_p(p)) return error("append2: improper list", car(x)); car(a) = car(p); new = cons(NIL, NIL); cdr(a) = new; pa = &cdr(a); a = cdr(a); } unsave(1); *pa = cadr(x); return n; } int assqv(char *who, int v, cell x, cell a) { cell p; char buf[64]; for (p = a; p != NIL; p = cdr(p)) { if (!pair_p(p) || !pair_p(car(p))) { sprintf(buf, "%s: bad element in alist", who); return error(buf, p); } if (!v && x == caar(p)) return car(p); if (v && eqv_p(x, caar(p))) return car(p); } return FALSE; } cell pp_assq(cell x) { return assqv("assq", 0, car(x), cadr(x)); } cell pp_assv(cell x) { return assqv("assv", 1, car(x), cadr(x)); } char *rev_cxr_name(char *s) { int i, k = strlen(s); static char buf[8]; for (i=0; i: expected number, got", cadr(x)); if (!real_less_p(cadr(x), car(x))) return FALSE; x = cdr(x); } return TRUE; } cell pp_greater_equal(cell x) { while (cdr(x) != NIL) { if (!number_p(cadr(x))) return error(">=: expected number, got", cadr(x)); if (real_less_p(car(x), cadr(x))) return FALSE; x = cdr(x); } return TRUE; } cell pp_less(cell x) { while (cdr(x) != NIL) { if (!number_p(cadr(x))) return error("<: expected number, got", cadr(x)); if (!real_less_p(car(x), cadr(x))) return FALSE; x = cdr(x); } return TRUE; } cell pp_less_equal(cell x) { while (cdr(x) != NIL) { if (!number_p(cadr(x))) return error("<=: expected number, got", cadr(x)); if (real_less_p(cadr(x), car(x))) return FALSE; x = cdr(x); } return TRUE; } cell limit(char *msg, int(*pred)(cell,cell), cell x) { cell k, p; int exact = 1; k = car(x); if (real_p(k)) exact = 0; for (p = cdr(x); p != NIL; p = cdr(p)) { if (!number_p(car(p))) return error(msg, (car(p))); if (real_p(car(p))) exact = 0; if (pred(car(p), k)) k = car(p); } if (exact) return k; if (integer_p(k)) return bignum_to_real(k); return k; } int real_greater_p(cell x, cell y) { return real_less_p(y, x); } cell pp_max(cell x) { return limit("max: expected number, got", real_greater_p, x); } cell pp_min(cell x) { return limit("min: expected number, got", real_less_p, x); } cell pp_minus(cell x) { cell a; if (cdr(x) == NIL) return real_negate(car(x)); a = car(x); x = cdr(x); save(a); while (x != NIL) { if (!number_p(car(x))) { unsave(1); return error("-: expected number, got", car(x)); } a = real_subtract(a, car(x)); car(Stack) = a; x = cdr(x); } unsave(1); return a; } cell pp_negative_p(cell x) { return real_negative_p(car(x))? TRUE: FALSE; } cell pp_odd_p(cell x) { return even_p("odd?", car(x))? FALSE: TRUE; } cell pp_plus(cell x) { cell a; if (x == NIL) return Zero; if (cdr(x) == NIL) return car(x); a = Zero; save(a); while (x != NIL) { if (!number_p(car(x))) { unsave(1); return error("+: expected number, got", car(x)); } a = real_add(a, car(x)); car(Stack) = a; x = cdr(x); } unsave(1); return a; } cell pp_quotient(cell x) { char *name; cell a, b; name = "quotient"; a = integer_argument(name, car(x)); save(a); b = integer_argument(name, cadr(x)); unsave(1); if (a == UNDEFINED || b == UNDEFINED) return UNDEFINED; a = bignum_divide(a, b); if (a == UNDEFINED) return error("divide by zero", x); return car(a); } cell pp_remainder(cell x) { char *name; cell a, b; name = "remainder"; /*LINT*/ a = integer_argument(name, car(x)); save(a); b = integer_argument(name, cadr(x)); unsave(1); if (a == UNDEFINED || b == UNDEFINED) return UNDEFINED; a = bignum_divide(a, b); if (a == UNDEFINED) return error("divide by zero", x); return cdr(a); } cell pp_positive_p(cell x) { return real_positive_p(car(x))? TRUE: FALSE; } cell pp_times(cell x) { cell a; if (x == NIL) return One; if (cdr(x) == NIL) return car(x); a = One; save(a); while (x != NIL) { if (!number_p(car(x))) { unsave(1); return error("*: expected number, got", car(x)); } a = real_multiply(a, car(x)); car(Stack) = a; x = cdr(x); } unsave(1); return a; } cell pp_zero_p(cell x) { return real_zero_p(car(x))? TRUE: FALSE; } cell pp_ceiling(cell x) { return real_ceil(car(x)); } cell pp_divide(cell x) { cell a; if (cdr(x) == NIL) return real_divide(One, car(x)); a = car(x); x = cdr(x); save(a); while (x != NIL) { if (!number_p(car(x))) { unsave(1); return error("/: expected number, got", car(x)); } a = real_divide(a, car(x)); if (a == UNDEFINED) { unsave(1); return a; } car(Stack) = a; x = cdr(x); } unsave(1); return a; } cell pp_exact_to_inexact(cell x) { cell n; int flags; x = car(x); if (integer_p(x)) { flags = bignum_negative_p(x)? REAL_NEGATIVE: 0; n = bignum_abs(x); n = S9_make_real(flags, 0, cdr(n)); if (n == UNDEFINED) return error("exact->inexact: overflow", x); return n; } return x; } cell pp_exact_p(cell x) { return integer_p(car(x))? TRUE: FALSE; } cell pp_exponent(cell x) { return make_integer(real_exponent(car(x))); } cell pp_floor(cell x) { return real_floor(car(x)); } cell pp_inexact_p(cell x) { return real_p(car(x))? TRUE: FALSE; } cell pp_inexact_to_exact(cell x) { cell n; x = car(x); if (integer_p(x)) return x; n = real_to_bignum(x); if (n != NIL) return n; return error("inexact->exact: no exact representation for", x); } cell pp_mantissa(cell x) { return real_mantissa(car(x)); } cell pp_real_p(cell x) { return number_p(car(x))? TRUE: FALSE; } cell pp_truncate(cell x) { return real_trunc(car(x)); } /* * Type Predicates and Conversion */ cell pp_boolean_p(cell x) { return boolean_p(car(x))? TRUE: FALSE; } cell pp_char_p(cell x) { return char_p(car(x))? TRUE: FALSE; } cell pp_char_to_integer(cell x) { return make_integer(char_value(car(x))); } cell pp_input_port_p(cell x) { return input_port_p(car(x))? TRUE: FALSE; } cell pp_integer_to_char(cell x) { cell n; n = integer_value("integer->char", car(x)); if (n < 0 || n > 255) return error("integer->char: argument value out of range", car(x)); return make_char(n); } cell pp_integer_p(cell x) { return real_integer_p(car(x))? TRUE: FALSE; } cell list_to_string(char *who, cell x) { cell n; int k = length(x); char *s; char buf[100]; n = make_string("", k); s = string(n); while (x != NIL) { if (atom_p(x)) return error("list->string: improper list", x); if (!char_p(car(x))) { sprintf(buf, "%s: expected list of char," " got list containing", who); return error(buf, car(x)); } *s++ = cadar(x); x = cdr(x); } *s = 0; return n; } cell pp_list_to_string(cell x) { return list_to_string("list->string", car(x)); } cell pp_list_to_vector(cell x) { return list_to_vector(car(x), "list->vector: improper list", 0); } cell pp_output_port_p(cell x) { return output_port_p(car(x))? TRUE: FALSE; } cell pp_pair_p(cell x) { return pair_p(car(x))? TRUE: FALSE; } cell pp_procedure_p(cell x) { return (function_p(car(x)) || primitive_p(car(x)) || continuation_p(car(x)))? TRUE: FALSE; } cell pp_string_to_list(cell x) { char *s; cell n, a, new; int k, i; k = string_len(car(x)); n = NIL; a = NIL; for (i=0; i= L(c2); } int char_ci_gt(int c1, int c2) { return L(c1) > L(c2); } int char_le(int c1, int c2) { return c1 <= c2; } int char_lt(int c1, int c2) { return c1 < c2; } int char_eq(int c1, int c2) { return c1 == c2; } int char_ge(int c1, int c2) { return c1 >= c2; } int char_gt(int c1, int c2) { return c1 > c2; } cell char_predicate(char *name, int (*p)(int c1, int c2), cell x) { char msg[100]; while (cdr(x) != NIL) { if (!char_p(cadr(x))) { sprintf(msg, "%s: expected char, got", name); return error(msg, cadr(x)); } if (!p(char_value(car(x)), char_value(cadr(x)))) return FALSE; x = cdr(x); } return TRUE; } #define CP return char_predicate cell pp_char_ci_le_p(cell x) { CP("char-ci<=?", char_ci_le, x); } cell pp_char_ci_lt_p(cell x) { CP("char-ci=?", char_ci_ge, x); } cell pp_char_ci_gt_p(cell x) { CP("char-ci>?", char_ci_gt, x); } cell pp_char_le_p(cell x) { CP("char<=?", char_le, x); } cell pp_char_lt_p(cell x) { CP("char=?", char_ge, x); } cell pp_char_gt_p(cell x) { CP("char>?", char_gt, x); } cell pp_char_downcase(cell x) { return make_char(tolower(char_value(car(x)))); } cell pp_char_lower_case_p(cell x) { return islower(char_value(car(x)))? TRUE: FALSE; } cell pp_char_numeric_p(cell x) { return isdigit(char_value(car(x)))? TRUE: FALSE; } cell pp_char_upcase(cell x) { return make_char(toupper(char_value(car(x)))); } cell pp_char_upper_case_p(cell x) { return isupper(char_value(car(x)))? TRUE: FALSE; } cell pp_char_whitespace_p(cell x) { int c = char_value(car(x)); return (c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f')? TRUE: FALSE; } /* * Strings */ cell pp_make_string(cell x) { cell n; int c, k; char *s; k = integer_value("make-string", car(x)); if (k < 0) return error("make-string: got negative length", x); n = make_string("", k); s = string(n); c = cdr(x) == NIL? ' ': char_value(cadr(x)); memset(s, c, k); s[k] = 0; return n; } cell pp_string(cell x) { return list_to_string("string", x); } cell pp_string_append(cell x) { cell p, n; int k, m; char *s; k = 0; for (p = x; p != NIL; p = cdr(p)) { if (!string_p(car(p))) return error("string-append: expected string, got", car(p)); k += string_len(car(p))-1; } n = make_string("", k); s = string(n); k = 0; for (p = x; p != NIL; p = cdr(p)) { m = string_len(car(p)); memcpy(&s[k], string(car(p)), m); k += string_len(car(p))-1; } return n; } cell pp_string_copy(cell x) { cell n, k; /* * Cannot pass name to make_string(), because * string(car(x)) may move during GC. */ k = string_len(car(x)); n = make_string("", k-1); memcpy(string(n), string(car(x)), k); return n; } cell pp_string_fill_b(cell x) { int c = char_value(cadr(x)), i, k = string_len(car(x))-1; char *s = string(car(x)); if (constant_p(car(x))) return error("string-fill!: immutable object", car(x)); for (i=0; i= k) return error("string-ref: index out of range", cadr(x)); return make_char(string(car(x))[p]); } cell pp_string_set_b(cell x) { int p, k = string_len(car(x))-1; if (constant_p(car(x))) return error("string-set!: immutable object", car(x)); p = integer_value("string-set!", cadr(x)); if (p < 0 || p >= k) return error("string-set!: index out of range", cadr(x)); string(car(x))[p] = char_value(caddr(x)); return UNSPECIFIC; } #define RT k=0; return int string_ci_le(char *s1, char *s2, int k) { RT strcmp_ci(s1, s2) <= 0; } int string_ci_lt(char *s1, char *s2, int k) { RT strcmp_ci(s1, s2) < 0; } int string_ci_ge(char *s1, char *s2, int k) { RT strcmp_ci(s1, s2) >= 0; } int string_ci_gt(char *s1, char *s2, int k) { RT strcmp_ci(s1, s2) > 0; } int string_ci_eq(char *s1, char *s2, int k) { return memcmp_ci(s1, s2, k) == 0; } int string_le(char *s1, char *s2, int k) { RT strcmp(s1, s2) <= 0; } int string_lt(char *s1, char *s2, int k) { RT strcmp(s1, s2) < 0; } int string_ge(char *s1, char *s2, int k) { RT strcmp(s1, s2) >= 0; } int string_gt(char *s1, char *s2, int k) { RT strcmp(s1, s2) > 0; } int string_eq(char *s1, char *s2, int k) { return memcmp(s1, s2, k) == 0; } cell string_predicate(char *name, int (*p)(char *s1, char *s2, int k), cell x) { char msg[100]; int k = 0; while (cdr(x) != NIL) { if (!string_p(cadr(x))) { sprintf(msg, "%s: expected string, got", name); return error(msg, cadr(x)); } if (p == string_eq || p == string_ci_eq) { k = string_len(car(x)); if (k != string_len(cadr(x))) return FALSE; } if (!p(string(car(x)), string(cadr(x)), k)) return FALSE; x = cdr(x); } return TRUE; } #define SP return string_predicate cell pp_string_ci_le_p(cell x) { SP("string-ci<=?", string_ci_le, x); } cell pp_string_ci_lt_p(cell x) { SP("string-ci=?", string_ci_ge, x); } cell pp_string_ci_gt_p(cell x) { SP("string-ci>?", string_ci_gt, x); } cell pp_string_le_p(cell x) { SP("string<=?", string_le, x); } cell pp_string_lt_p(cell x) { SP("string=?", string_ge, x); } cell pp_string_gt_p(cell x) { SP("string>?", string_gt, x); } cell pp_substring(cell x) { int k = string_len(car(x))-1; int p0 = integer_value("substring", cadr(x)); int pn = integer_value("substring", caddr(x)); char *src, *dst; cell n; if (p0 < 0 || p0 > k || pn < 0 || pn > k || pn < p0) { n = cons(caddr(x), NIL); return error("substring: invalid range", cons(cadr(x), n)); } n = make_string("", pn-p0); dst = string(n); src = string(car(x)); if (pn-p0 != 0) memcpy(dst, &src[p0], pn-p0); dst[pn-p0] = 0; return n; } /* * Vectors */ cell pp_make_vector(cell x) { int i, k; cell n, *v, m; k = integer_value("make-vector", car(x)); if (k < 0) return error("make-vector: got negative length", car(x)); n = new_vec(T_VECTOR, k * sizeof(cell)); v = vector(n); m = cdr(x) == NIL? FALSE: cadr(x); for (i=0; i kn) return error("vector-copy: bad range", VOID); if (x != NIL) { fill = car(x); x = cdr(x); } if (x != NIL) return error("vector-copy: too many arguments", VOID); n = new_vec(T_VECTOR, (kn-k0) * sizeof(cell)); nv = vector(n); ov = vector(vec); for (j = 0, i = k0; i < kn; i++, j++) if (i >= k) nv[j] = fill; else nv[j] = ov[i]; return n; } cell pp_vector_fill_b(cell x) { cell fill = cadr(x); int i, k = vector_len(car(x)); cell *v = vector(car(x)); if (constant_p(car(x))) return error("vector-fill!: immutable object", car(x)); for (i=0; i= k) return error("vector-ref: index out of range", cadr(x)); return vector(car(x))[p]; } cell pp_vector_set_b(cell x) { int p, k = vector_len(car(x)); if (constant_p(car(x))) return error("vector-set!: immutable object", car(x)); p = integer_value("vector-set!", cadr(x)); if (p < 0 || p >= k) return error("vector-set!: index out of range", cadr(x)); vector(car(x))[p] = caddr(x); return UNSPECIFIC; } /* * I/O */ cell pp_close_input_port(cell x) { if (port_no(car(x)) < 2) return error("please do not close the standard input port", VOID); close_port(port_no(car(x))); return UNSPECIFIC; } cell pp_close_output_port(cell x) { if (port_no(car(x)) < 2) return error("please do not close the standard output port", VOID); close_port(port_no(car(x))); return UNSPECIFIC; } cell pp_current_input_port(cell x) { return make_port(input_port(), T_INPUT_PORT); } cell pp_current_output_port(cell x) { return make_port(output_port(), T_OUTPUT_PORT); } cell pp_write(cell x); cell pp_display(cell x) { Displaying = 1; pp_write(x); Displaying = 0; return UNSPECIFIC; } cell pp_eof_object_p(cell x) { return car(x) == END_OF_FILE? TRUE: FALSE; } cell eval(cell x); int load(char *file) { int n; int outer_lno; int outer_loading; int new_port, old_port; new_port = open_input_port(file); if (new_port == -1) return -1; lock_port(new_port); File_list = cons(make_string(file, (int) strlen(file)), File_list); save(Environment); while (cdr(Environment) != NIL) Environment = cdr(Environment); Load_level++; outer_loading = box_value(S_loading); box_value(S_loading) = TRUE; old_port = input_port(); outer_lno = Line_no; Line_no = 1; while (!Error_flag) { set_input_port(new_port); n = xread(); set_input_port(old_port); if (n == END_OF_FILE) break; if (!Error_flag) eval(n); } unlock_port(new_port); close_port(new_port); Line_no = outer_lno; box_value(S_loading) = outer_loading; Load_level--; File_list = cdr(File_list); rehash(car(Environment)); Environment = unsave(1); return 0; } cell pp_load(cell x) { char file[TOKEN_LENGTH+1]; if (string_len(car(x)) > TOKEN_LENGTH) return error("load: path too long", car(x)); strcpy(file, string(car(x))); if (load(file) < 0) return error("load: cannot open file", car(x)); return UNSPECIFIC; } cell pp_open_input_file(cell x) { int p; p = open_input_port(string(car(x))); if (p < 0) return error("open-input-file: could not open file", car(x)); return make_port(p, T_INPUT_PORT); } cell pp_open_output_file(cell x) { int p; p = open_output_port(string(car(x)), 0); if (p < 0) return error("open-output-file: could not open file", car(x)); return make_port(p, T_OUTPUT_PORT); } cell pp_read(cell x) { cell n; int new_port, old_port; new_port = x == NIL? input_port(): port_no(car(x)); if (new_port < 0 || new_port >= MAX_PORTS) return error("read: invalid input port (oops)", car(x)); old_port = input_port(); set_input_port(new_port); n = xread(); set_input_port(old_port); return n; } cell read_char(cell x, int unget) { int c, new_port, old_port; new_port = x == NIL? input_port(): port_no(car(x)); if (new_port < 0 || new_port >= MAX_PORTS) return error("read-char: invalid input port (oops)", car(x)); old_port = input_port(); set_input_port(new_port); c = readc(); if (unget) rejectc(c); set_input_port(old_port); return c == EOF? END_OF_FILE: make_char(c); } cell pp_peek_char(cell x) { return read_char(x, 1); } cell pp_read_char(cell x) { return read_char(x, 0); } cell pp_write(cell x) { int new_port, old_port; new_port = cdr(x) == NIL? output_port(): port_no(cadr(x)); if (new_port < 0 || new_port >= MAX_PORTS) return error("write: invalid output port (oops)", cadr(x)); old_port = output_port(); set_output_port(new_port); print_form(car(x)); set_output_port(old_port); return UNSPECIFIC; } cell pp_write_char(cell x) { return pp_display(x); } /* * Extensions */ cell pp_bit_op(cell x) { char name[] = "bit-op"; cell op, a, b; static cell mask = 0; if (mask == 0) { mask = 1; while (mask <= S9_INT_SEG_LIMIT) mask <<= 1; if (mask > S9_INT_SEG_LIMIT) mask >>= 1; mask--; } op = integer_value(name, car(x)); x = cdr(x); a = integer_value(name, car(x)); for (x = cdr(x); x != NIL; x = cdr(x)) { b = integer_value(name, car(x)); if (a & ~mask || b & ~mask || a < 0 || b < 0) return FALSE; switch (op) { case 0: a = 0; break; case 1: a = a & b; break; case 2: a = a & ~b; break; case 3: /* a = a; */ break; case 4: a = ~a & b; break; case 5: a = b; break; case 6: a = a ^ b; break; case 7: a = a | b; break; case 8: a = ~(a | b); break; case 9: a = ~(a ^ b); break; case 10: a = ~b; break; case 11: a = a | ~b; break; case 12: a = ~a; break; case 13: a = ~a | b; break; case 14: a = ~(a & b); break; case 15: a = ~0; break; case 16: a = a << b; break; case 17: a = a >> b; break; default: return FALSE; break; } a &= mask; } return make_integer(a); } cell pp_delete_file(cell x) { if (remove(string(car(x))) < 0) error("delete-file: file does not exist", car(x)); return UNSPECIFIC; } cell pp_error(cell x) { return error(string(car(x)), cdr(x) != NIL? cadr(x): VOID); } cell pp_eval(cell x) { return eval(car(x)); } cell pp_file_exists_p(cell x) { FILE *f; f = fopen(string(car(x)), "r"); if (f == NULL) return FALSE; fclose(f); return TRUE; } cell gensym(char *prefix) { static long g = 0; char s[200]; do { sprintf(s, "%s%ld", prefix, g); g++; } while (find_symbol(s) != NIL); return symbol_ref(s); } cell pp_gensym(cell x) { char pre[101]; int k; if (x == NIL) { strcpy(pre, "g"); k = 1; } else if (string_p(car(x))) { memcpy(pre, string(car(x)), 100); k = string_len(car(x)); } else if (symbol_p(car(x))) { memcpy(pre, symbol_name(car(x)), 100); k = symbol_len(car(x)); } else return error("gensym: expected string or symbol, got", car(x)); if (k > 100) return error("gensym: prefix too long", car(x)); pre[100] = 0; return gensym(pre); } cell expand_syntax(cell x); cell pp_macro_expand(cell x) { x = car(x); save(x); x = expand_syntax(x); unsave(1); return x; } cell expand_syntax_1(cell x); cell pp_macro_expand_1(cell x) { x = car(x); save(x); x = expand_syntax_1(x); unsave(1); return x; } cell pp_reverse_b(cell x) { cell n, m, h; m = NIL; n = car(x); while (n != NIL) { if (constant_p(n)) return error("reverse!: immutable object", n); if (!pair_p(n)) return error("reverse!: expected list, got", car(x)); h = cdr(n); cdr(n) = m; m = n; n = h; } return m; } cell pp_set_input_port_b(cell x) { set_input_port(port_no(car(x))); return UNSPECIFIC; } cell pp_set_output_port_b(cell x) { set_output_port(port_no(car(x))); return UNSPECIFIC; } cell pp_stats(cell x) { cell n, m; counter *nodes, *conses, *collections; gcv(); /* start from a known state */ reset_counter(&Reductions); run_stats(1); cons_stats(0); Eval_stats = 1; n = eval(car(x)); Eval_stats = 0; run_stats(0); get_counters(&nodes, &conses, &collections); save(n); n = read_counter(collections); n = cons(n, NIL); save(n); car(Stack) = n; m = read_counter(nodes); n = cons(m, n); car(Stack) = n; m = read_counter(conses); n = cons(m, n); car(Stack) = n; m = read_counter(&Reductions); n = cons(m, n); n = cons(unsave(2), n); return n; } cell pp_symbols(cell x) { cell n, a, y, new; n = NIL; a = NIL; for (y = symbol_table(); y != NIL; y = cdr(y)) { if (n == NIL) { n = a = cons(car(y), NIL); save(n); } else { new = cons(car(y), NIL); cdr(a) = new; a = cdr(a); } } if (n != NIL) unsave(1); return n; } #ifdef unix cell pp_argv(cell x) { cell n, a; a = binding_value(S_arguments); if (a == NIL) return FALSE; n = integer_value("argv", car(x)); for (; a != NIL && n > 0; a = cdr(a), n--) ; return a == NIL? FALSE: car(a); } cell pp_environ(cell x) { char *s; s = getenv(string(car(x))); if (s == NULL) return FALSE; return make_string(s, strlen(s)); } cell pp_system(cell x) { int r; r = system(string(car(x))); return make_integer(r >> 8); } #endif /* unix */ /* * Evaluator */ S9_PRIM Core_primitives[] = { { "*", pp_times, 0, -1, { REA,___,___ } }, { "+", pp_plus, 0, -1, { REA,___,___ } }, { "-", pp_minus, 1, -1, { REA,___,___ } }, { "/", pp_divide, 1, -1, { REA,___,___ } }, { "<", pp_less, 2, -1, { REA,___,___ } }, { "<=", pp_less_equal, 2, -1, { REA,___,___ } }, { "=", pp_equal, 2, -1, { REA,___,___ } }, { ">", pp_greater, 2, -1, { REA,___,___ } }, { ">=", pp_greater_equal, 2, -1, { REA,___,___ } }, { "abs", pp_abs, 1, 1, { REA,___,___ } }, { "append2", pp_append2, 2, 2, { LST,___,___ } }, { "apply", pp_apply, 2, -1, { FUN,___,___ } }, { "assq", pp_assq, 2, 2, { ___,LST,___ } }, { "assv", pp_assv, 2, 2, { ___,LST,___ } }, { "bit-op", pp_bit_op, 3, -1, { INT,INT,INT } }, { "boolean?", pp_boolean_p, 1, 1, { ___,___,___ } }, { "caar", pp_caar, 1, 1, { PAI,___,___ } }, { "cadr", pp_cadr, 1, 1, { PAI,___,___ } }, { "cdar", pp_cdar, 1, 1, { PAI,___,___ } }, { "cddr", pp_cddr, 1, 1, { PAI,___,___ } }, { "caaar", pp_caaar, 1, 1, { PAI,___,___ } }, { "caadr", pp_caadr, 1, 1, { PAI,___,___ } }, { "cadar", pp_cadar, 1, 1, { PAI,___,___ } }, { "caddr", pp_caddr, 1, 1, { PAI,___,___ } }, { "call/cc", pp_call_cc, 1, 1, { FUN,___,___ } }, { "cdaar", pp_cdaar, 1, 1, { PAI,___,___ } }, { "cdadr", pp_cdadr, 1, 1, { PAI,___,___ } }, { "cddar", pp_cddar, 1, 1, { PAI,___,___ } }, { "cdddr", pp_cdddr, 1, 1, { PAI,___,___ } }, { "caaaar", pp_caaaar, 1, 1, { PAI,___,___ } }, { "caaadr", pp_caaadr, 1, 1, { PAI,___,___ } }, { "caadar", pp_caadar, 1, 1, { PAI,___,___ } }, { "caaddr", pp_caaddr, 1, 1, { PAI,___,___ } }, { "cadaar", pp_cadaar, 1, 1, { PAI,___,___ } }, { "cadadr", pp_cadadr, 1, 1, { PAI,___,___ } }, { "caddar", pp_caddar, 1, 1, { PAI,___,___ } }, { "cadddr", pp_cadddr, 1, 1, { PAI,___,___ } }, { "cdaaar", pp_cdaaar, 1, 1, { PAI,___,___ } }, { "cdaadr", pp_cdaadr, 1, 1, { PAI,___,___ } }, { "cdadar", pp_cdadar, 1, 1, { PAI,___,___ } }, { "cdaddr", pp_cdaddr, 1, 1, { PAI,___,___ } }, { "cddaar", pp_cddaar, 1, 1, { PAI,___,___ } }, { "cddadr", pp_cddadr, 1, 1, { PAI,___,___ } }, { "cdddar", pp_cdddar, 1, 1, { PAI,___,___ } }, { "cddddr", pp_cddddr, 1, 1, { PAI,___,___ } }, { "car", pp_car, 1, 1, { PAI,___,___ } }, { "cdr", pp_cdr, 1, 1, { PAI,___,___ } }, { "ceiling", pp_ceiling, 1, 1, { REA,___,___ } }, { "char->integer", pp_char_to_integer, 1, 1, { CHR,___,___ } }, { "char-alphabetic?", pp_char_alphabetic_p, 1, 1, { CHR,___,___ } }, { "char-ci<=?", pp_char_ci_le_p, 2, -1, { CHR,___,___ } }, { "char-ci=?", pp_char_ci_ge_p, 2, -1, { CHR,___,___ } }, { "char-ci>?", pp_char_ci_gt_p, 2, -1, { CHR,___,___ } }, { "char-downcase", pp_char_downcase, 1, 1, { CHR,___,___ } }, { "char-lower-case?", pp_char_lower_case_p, 1, 1, { CHR,___,___ } }, { "char-numeric?", pp_char_numeric_p, 1, 1, { CHR,___,___ } }, { "char-upcase", pp_char_upcase, 1, 1, { CHR,___,___ } }, { "char-upper-case?", pp_char_upper_case_p, 1, 1, { CHR,___,___ } }, { "char-whitespace?", pp_char_whitespace_p, 1, 1, { CHR,___,___ } }, { "char<=?", pp_char_le_p, 2, -1, { CHR,___,___ } }, { "char=?", pp_char_ge_p, 2, -1, { CHR,___,___ } }, { "char>?", pp_char_gt_p, 2, -1, { CHR,___,___ } }, { "char?", pp_char_p, 1, 1, { ___,___,___ } }, { "close-input-port", pp_close_input_port, 1, 1, { INP,___,___ } }, { "close-output-port", pp_close_output_port, 1, 1, { OUP,___,___ } }, { "cons", pp_cons, 2, 2, { ___,___,___ } }, { "current-input-port", pp_current_input_port, 0, 0, { ___,___,___ } }, { "current-output-port", pp_current_output_port, 0, 0, { ___,___,___ } }, { "delete-file", pp_delete_file, 1, 1, { STR,___,___ } }, { "display", pp_display, 1, 2, { ___,OUP,___ } }, { "eof-object?", pp_eof_object_p, 1, 1, { ___,___,___ } }, { "eq?", pp_eq_p, 2, 2, { ___,___,___ } }, { "eqv?", pp_eqv_p, 2, 2, { ___,___,___ } }, { "error", pp_error, 1, 2, { STR,___,___ } }, { "eval", pp_eval, 1, 2, { ___,___,___ } }, { "even?", pp_even_p, 1, 1, { REA,___,___ } }, { "exact->inexact", pp_exact_to_inexact, 1, 1, { REA,___,___ } }, { "exact?", pp_exact_p, 1, 1, { REA,___,___ } }, { "expt", pp_expt, 2, 2, { REA,REA,___ } }, { "exponent", pp_exponent, 1, 1, { REA,___,___ } }, { "file-exists?", pp_file_exists_p, 1, 1, { STR,___,___ } }, { "floor", pp_floor, 1, 1, { REA,___,___ } }, { "gensym", pp_gensym, 0, 1, { ___,___,___ } }, { "inexact->exact", pp_inexact_to_exact, 1, 1, { REA,___,___ } }, { "inexact?", pp_inexact_p, 1, 1, { REA,___,___ } }, { "input-port?", pp_input_port_p, 1, 1, { ___,___,___ } }, { "integer->char", pp_integer_to_char, 1, 1, { INT,___,___ } }, { "integer?", pp_integer_p, 1, 1, { ___,___,___ } }, { "length", pp_length, 1, 1, { LST,___,___ } }, { "list", pp_list, 0, -1, { ___,___,___ } }, { "list->string", pp_list_to_string, 1, 1, { LST,___,___ } }, { "list->vector", pp_list_to_vector, 1, 1, { LST,___,___ } }, { "list-tail", pp_list_tail, 2, 2, { LST,INT,___ } }, { "load", pp_load, 1, 1, { STR,___,___ } }, { "macro-expand", pp_macro_expand, 1, 1, { ___,___,___ } }, { "macro-expand-1", pp_macro_expand_1, 1, 1, { ___,___,___ } }, { "make-string", pp_make_string, 1, 2, { INT,CHR,___ } }, { "make-vector", pp_make_vector, 1, 2, { INT,___,___ } }, { "mantissa", pp_mantissa, 1, 1, { REA,___,___ } }, { "max", pp_max, 1, -1, { REA,___,___ } }, { "memq", pp_memq, 2, 2, { ___,LST,___ } }, { "memv", pp_memv, 2, 2, { ___,LST,___ } }, { "min", pp_min, 1, -1, { REA,___,___ } }, { "negative?", pp_negative_p, 1, 1, { REA,___,___ } }, { "not", pp_not, 1, 1, { ___,___,___ } }, { "null?", pp_null_p, 1, 1, { ___,___,___ } }, { "odd?", pp_odd_p, 1, 1, { REA,___,___ } }, { "open-input-file", pp_open_input_file, 1, 1, { STR,___,___ } }, { "open-output-file", pp_open_output_file, 1, 1, { STR,___,___ } }, { "output-port?", pp_output_port_p, 1, 1, { ___,___,___ } }, { "pair?", pp_pair_p, 1, 1, { ___,___,___ } }, { "peek-char", pp_peek_char, 0, 1, { INP,___,___ } }, { "positive?", pp_positive_p, 1, 1, { REA,___,___ } }, { "procedure?", pp_procedure_p, 1, 1, { ___,___,___ } }, { "quotient", pp_quotient, 2, 2, { REA,REA,___ } }, { "read", pp_read, 0, 1, { INP,___,___ } }, { "read-char", pp_read_char, 0, 1, { INP,___,___ } }, { "real?", pp_real_p, 1, 1, { ___,___,___ } }, { "remainder", pp_remainder, 2, 2, { REA,REA,___ } }, { "reverse", pp_reverse, 1, 1, { LST,___,___ } }, { "reverse!", pp_reverse_b, 1, 1, { LST,___,___ } }, { "set-car!", pp_set_car_b, 2, 2, { PAI,___,___ } }, { "set-cdr!", pp_set_cdr_b, 2, 2, { PAI,___,___ } }, { "set-input-port!", pp_set_input_port_b, 1, 1, { INP,___,___ } }, { "set-output-port!", pp_set_output_port_b, 1, 1, { OUP,___,___ } }, { "stats", pp_stats, 1, 1, { ___,___,___ } }, { "string", pp_string, 0, -1, { CHR,___,___ } }, { "string->list", pp_string_to_list, 1, 1, { STR,___,___ } }, { "string->symbol", pp_string_to_symbol, 1, 1, { STR,___,___ } }, { "string-append", pp_string_append, 0, -1, { STR,___,___ } }, { "string-ci<=?", pp_string_ci_le_p, 2, -1, { STR,___,___ } }, { "string-ci=?", pp_string_ci_ge_p, 2, -1, { STR,___,___ } }, { "string-ci>?", pp_string_ci_gt_p, 2, -1, { STR,___,___ } }, { "string-copy", pp_string_copy, 1, 1, { STR,___,___ } }, { "string-fill!", pp_string_fill_b, 2, 2, { STR,CHR,___ } }, { "string-length", pp_string_length, 1, 1, { STR,___,___ } }, { "string-ref", pp_string_ref, 2, 2, { STR,INT,___ } }, { "string-set!", pp_string_set_b, 3, 3, { STR,INT,CHR } }, { "string<=?", pp_string_le_p, 2, -1, { STR,___,___ } }, { "string=?", pp_string_ge_p, 2, -1, { STR,___,___ } }, { "string>?", pp_string_gt_p, 2, -1, { STR,___,___ } }, { "string?", pp_string_p, 1, 1, { ___,___,___ } }, { "substring", pp_substring, 3, 3, { STR,INT,INT } }, { "symbol->string", pp_symbol_to_string, 1, 1, { SYM,___,___ } }, { "symbols", pp_symbols, 0, 0, { ___,___,___ } }, { "symbol?", pp_symbol_p, 1, 1, { ___,___,___ } }, { "truncate", pp_truncate, 1, 1, { REA,___,___ } }, { "unquote", pp_unquote, 1, 1, { ___,___,___ } }, { "unquote-splicing", pp_unquote_splicing, 1, 1, { ___,___,___ } }, { "vector", pp_vector, 0, -1, { ___,___,___ } }, { "vector->list", pp_vector_to_list, 1, 1, { VEC,___,___ } }, { "vector-append", pp_vector_append, 0, -1, { VEC,___,___ } }, { "vector-copy", pp_vector_copy, 1, -1, { VEC,INT,INT } }, { "vector-fill!", pp_vector_fill_b, 2, 2, { VEC,___,___ } }, { "vector-length", pp_vector_length, 1, 1, { VEC,___,___ } }, { "vector-ref", pp_vector_ref, 2, 2, { VEC,INT,___ } }, { "vector-set!", pp_vector_set_b, 3, 3, { VEC,INT,___ } }, { "vector?", pp_vector_p, 1, 1, { ___,___,___ } }, { "write", pp_write, 1, 2, { ___,OUP,___ } }, { "write-char", pp_write_char, 1, 2, { CHR,OUP,___ } }, { "zero?", pp_zero_p, 1, 1, { REA,___,___ } }, #ifdef unix { "argv", pp_argv, 1, 1, { INT,___,___ } }, { "environ", pp_environ, 1, 1, { STR,___,___ } }, { "system", pp_system, 1, 1, { STR,___,___ } }, #endif { NULL } }; cell expected(cell who, char *what, cell got) { char msg[100]; S9_PRIM *p; p = &Primitives[cadr(who)]; sprintf(msg, "%s: expected %s, got", p->name, what); return error(msg, got); } cell apply_primitive(cell x) { cell op, args; char *s; op = car(x); args = cdr(x); if ((s = typecheck(op, args)) != NULL) return error(s, args); return apply_prim(op, args); } int uses_transformer_p(cell x) { cell y; int special = 0; if (atom_p(x) || car(x) == S_quote) return 0; /* Skip argument lists of LAMBDA and DEFINE */ if ( pair_p(x) && (car(x) == S_lambda || car(x) == S_define) && pair_p(cdr(x)) && pair_p(cadr(x)) ) { x = cddr(x); special = 1; } if (!special && pair_p(x) && symbol_p(car(x))) { y = lookup(car(x), Environment, 0); if (y != NIL && syntax_p(binding_value(y))) return 1; } while (pair_p(x)) { if (uses_transformer_p(car(x))) return 1; x = cdr(x); } return 0; } cell xeval(cell x, int cbn); cell expand_syntax_1(cell x) { cell y, m, n, a, app; if (Error_flag || atom_p(x) || car(x) == S_quote) return x; if (symbol_p(car(x))) { y = lookup(car(x), Environment, 0); if (y != NIL && syntax_p(binding_value(y))) { save(x); app = cons(cdr(binding_value(y)), cdr(x)); unsave(1); return xeval(app, 1); } } /* * If DEFINE-SYNTAX is followed by (MACRO-NAME ...) * unbind the MACRO-NAME first to avoid erroneous * expansion. */ if ( car(x) == S_define_syntax && pair_p(cdr(x)) && pair_p(cadr(x)) ) { m = lookup(caadr(x), Environment, 0); if (m != NIL) binding_value(m) = UNDEFINED; } n = a = NIL; save(n); /* * If LAMBDA or DEFINE is followed by an argument list, * skip over it */ if ( (car(x) == S_lambda || car(x) == S_define) && pair_p(x) && pair_p(cadr(x)) ) { n = cons(car(x), cons(cadr(x), NIL)); car(Stack) = n; a = cdr(n); x = cddr(x); } while (pair_p(x)) { m = cons(expand_syntax_1(car(x)), NIL); if (n == NIL) { n = m; car(Stack) = n; a = n; } else { cdr(a) = m; a = cdr(a); } x = cdr(x); } cdr(a) = x; unsave(1); return n; } cell expand_syntax(cell x) { if (Error_flag || atom_p(x) || car(x) == S_quote) return x; save(x); while (!Error_flag) { if (!uses_transformer_p(x)) break; x = expand_syntax_1(x); car(Stack) = x; } unsave(1); return x; } cell restore_state(void) { cell v; if (State_stack == NIL) fatal("restore_state: stack underflow"); v = car(State_stack); State_stack = cdr(State_stack); return v; } cell bind_arguments(cell n) { cell p, v, a; cell rib; save(Environment); p = car(n); a = cdr(n); v = cadr(p); Environment = cdddr(p); rib = NIL; save(rib); while (pair_p(v)) { if (atom_p(a)) { unsave(1); return too_few_args(n); } Tmp = make_binding(car(v), car(a)); rib = cons(Tmp, rib); car(Stack) = rib; v = cdr(v); a = cdr(a); } if (symbol_p(v)) { Tmp = make_binding(v, a); rib = cons(Tmp, rib); car(Stack) = rib; } else if (a != NIL) { unsave(1); return too_many_args(n); } Tmp = NIL; unsave(1); Environment = make_env(rib, Environment); return UNSPECIFIC; } int tail_call(void) { if (State_stack == NIL || car(State_stack) != EV_BETA) return 0; Tmp = unsave(1); Environment = car(Stack); unsave(2); restore_state(); save(Tmp); Tmp = NIL; return 1; } void trace(cell name, cell expr) { if (Error_flag) return; if ( Trace_list == TRUE || memqv("trace", 0, name, Trace_list) != FALSE ) { prints("+ "); print_form(cons(name, cdr(expr))); nl(); } } cell xeval(cell x, int cbn) { cell m2, /* Root of result list */ a, /* Used to append to result */ rib; /* Temp storage for args */ int s, /* Current state */ c; /* Continue */ cell name; /* Name of procedure to apply */ save(x); save(State_stack); save(Stack_bottom); Stack_bottom = Stack; s = EV_ATOM; c = 0; while (!Error_flag) { if (Eval_stats) { count(&Reductions); } if (symbol_p(x)) { /* Symbol -> Value */ if (cbn) { Acc = x; cbn = 0; } else { Acc = lookup(x, Environment, 1); if (Error_flag) break; Acc = box_value(Acc); } } else if (auto_quoting_p(x) || cbn == 2) { Acc = x; /* Object -> Object */ cbn = 0; } else { /* (...) -> Value */ /* * This block is used to DESCEND into lists. * The following structure is saved on the * Stack: RIB = (args append result source) * The current s is saved on the State_stack. */ Acc = x; x = car(x); save_state(s); /* Check call-by-name built-ins and flag */ if (special_form_p(x) || cbn) { cbn = 0; rib = cons(Acc, Acc); /* result/source */ rib = cons(NIL, rib); /* append */ rib = cons(NIL, rib); /* args */ if (!proper_list_p(Acc)) error("syntax error", Acc); x = NIL; } else { Tmp = cons(NIL, NIL); rib = cons(Tmp, Acc); /* result/source */ rib = cons(Tmp, rib); /* append */ rib = cons(cdr(Acc), rib); /* args */ Tmp = NIL; x = car(Acc); } save(rib); s = EV_ARGS; continue; } /* * The following loop is used to ASCEND back to the * root of a list, thereby performing BETA REDUCTION. */ while (!Error_flag) if (s == EV_BETA) { /* Finish BETA reduction */ Environment = unsave(1); unsave(1); /* source expression */ s = restore_state(); } else if (s == EV_ARGS) { /* append to list, reduce */ rib = car(Stack); x = rib_args(rib); a = rib_append(rib); m2 = rib_result(rib); if (a != NIL) /* Append new member */ car(a) = Acc; if (x == NIL) { /* End of list */ Acc = m2; /* Remember name of caller */ name = car(rib_source(rib)); if (Trace_list != NIL) trace(name, Acc); if (primitive_p(car(Acc))) { if (cadar(Acc) == Apply_magic) c = cbn = 1; if (cadar(Acc) == Callcc_magic) c = cbn = 1; cons_stats(1); Acc = x = apply_primitive(Acc); cons_stats(0); } else if (special_form_p(car(Acc))) { Acc = x = apply_special(Acc, &c, &s); } else if (function_p(car(Acc))) { name = symbol_p(name)? name: NIL; Called_procedures[Proc_ptr] = name; Proc_ptr++; if (Proc_ptr >= MAX_CALL_TRACE) Proc_ptr = 0; tail_call(); bind_arguments(Acc); x = caddar(Acc); c = 2; s = EV_BETA; } else if (continuation_p(car(Acc))) { Acc = resume(Acc); } else { error("application of non-procedure", name); x = NIL; } if (c != 2) { unsave(1); /* drop source expr */ s = restore_state(); } /* Leave the ASCENDING loop and descend */ /* once more into X. */ if (c) break; } else if (atom_p(x)) { error("syntax error", rib_source(rib)); x = NIL; break; } else { /* X =/= NIL: append to list */ /* Create space for next argument */ Acc = cons(NIL, NIL); cdr(a) = Acc; rib_append(rib) = cdr(a); rib_args(rib) = cdr(x); x = car(x); /* evaluate next member */ break; } } else if (s == EV_IF_PRED) { x = unsave(1); unsave(1); /* source expression */ s = restore_state(); if (Acc != FALSE) x = cadr(x); else x = caddr(x); c = 1; break; } else if (s == EV_AND || s == EV_OR) { Stack = cons(cdar(Stack), cdr(Stack)); if ( (Acc == FALSE && s == EV_AND) || (Acc != FALSE && s == EV_OR) || car(Stack) == NIL ) { unsave(2); /* state, source expr */ s = restore_state(); x = Acc; cbn = 2; } else if (cdar(Stack) == NIL) { x = caar(Stack); unsave(2); /* state, source expr */ s = restore_state(); } else { x = caar(Stack); } c = 1; break; } else if (s == EV_COND) { char cond_err[] = "cond: invalid syntax"; if (Acc != FALSE) { x = cdaar(Stack); if (x == NIL) { x = quote(Acc, S_quote); } else if (pair_p(cdr(x))) { if (car(x) == S_arrow) { if (cddr(x) != NIL) error(cond_err, x); Acc = quote(Acc, S_quote); Acc = cons(Acc, NIL); Acc = x = cons(cadr(x), Acc); } else { Acc = x = cons(S_begin, x); } } else { x = car(x); } unsave(2); /* state, source expr */ s = restore_state(); } else if (cdar(Stack) == NIL) { unsave(2); /* state, source expr */ s = restore_state(); x = UNSPECIFIC; } else { Stack = cons(cdar(Stack), cdr(Stack)); x = caaar(Stack); if (x == S_else && cdar(Stack) == NIL) x = TRUE; } c = 1; break; } else if (s == EV_BEGIN) { Stack = cons(cdar(Stack), cdr(Stack)); if (cdar(Stack) == NIL) { x = caar(Stack); unsave(2); /* state, source expr */ s = restore_state(); } else { x = caar(Stack); } c = 1; break; } else if (s == EV_SET_VAL || s == EV_MACRO) { char err[] = "define-syntax: expected procedure, got"; if (s == EV_MACRO) { if (function_p(Acc)) { Acc = new_atom(T_SYNTAX, Acc); } if (syntax_p(Acc)) { /* Acc = Acc; */ } else { error(err, Acc); break; } } x = unsave(1); unsave(1); /* source expression */ s = restore_state(); box_value(x) = Acc; Acc = x = UNSPECIFIC; c = 0; break; } else { /* s == EV_ATOM */ break; } if (c) { /* Continue evaluation if requested */ c = 0; continue; } if (Stack == Stack_bottom) break; } Stack = Stack_bottom; Stack_bottom = unsave(1); State_stack = unsave(1); unsave(1); return Acc; /* Return the evaluated expr */ } void reset_calltrace(void) { int i; for (i=0; i "); flush(); } Intr_flag = 0; Program = xread(); if (Program == END_OF_FILE && !Intr_flag) break; if (!Error_flag) n = eval(Program); if (!Error_flag && !unspecific_p(n)) { print_form(n); prints("\n"); box_value(S_latest) = n; } if (Error_flag) Environment = car(sane_env); } unsave(1); prints("\n"); } /* * Startup and Initialization */ int exists(char *p) { FILE *f; if ((f = fopen(p, "r")) == NULL) return 0; fclose(f); return 1; } cell get_library_path(void) { char *s; s = getenv("S9FES_LIBRARY_PATH"); if (s == NULL) s = LIBRARY_PATH; return make_string(s, (int) strlen(s)); } int try_image(char *p, char *i) { char path[TOKEN_LENGTH]; char *msg; cell new; if (strlen(p) + strlen(i) + 8 >= TOKEN_LENGTH) { error("image path too long", make_string(p, strlen(p))); return 0; } sprintf(path, "%s/%s.image", p, i); if (!exists(path)) return 0; if ((msg = load_image(path, S9magic)) != NULL) { error(msg, make_string(path, strlen(path))); fatal("bad image file"); } /* *library-path* is overwritten by image */ new = get_library_path(); box_value(S_library_path) = new; return 1; } int try_src(char *p, char *i) { char path[TOKEN_LENGTH]; if (strlen(p) + strlen(i) + 6 >= TOKEN_LENGTH) { error("source path too long", make_string(p, strlen(p))); return 0; } sprintf(path, "%s/%s.scm", p, i); return load(path) == 0; } void load_library(char *argv0) { char pathbuf[TOKEN_LENGTH]; char *libpath; char *s; char s9[] = "s9"; if ((s = strrchr(argv0, '/')) != NULL) argv0 = s+1; libpath = string(binding_value(S_library_path)); if (strlen(libpath) >= TOKEN_LENGTH) fatal("library path too long"); if (!strcmp(argv0, "-")) { if (try_src(".", s9)) return; if (libpath && try_src(libpath, s9)) return; } else { libpath = strcpy(pathbuf, libpath); s = strtok(libpath, ":"); while (s != NULL) { if (try_image(s, argv0)) return; s = strtok(NULL, ":"); } libpath = strcpy(pathbuf, libpath); s = strtok(libpath, ":"); while (s != NULL) { if (try_src(s, argv0)) return; s = strtok(NULL, ":"); } } fatal("no suitable image file or library source found"); } void add_primitives(char *name, S9_PRIM *p) { cell v, n, new; int i; if (name) { n = symbol_ref(name); if (box_value(S_extensions) == NIL) { new = cons(n, box_value(S_extensions)); box_value(S_extensions) = new; } else { new = cons(n, NIL); append_b(box_value(S_extensions), new); } } for (i=0; p && p[i].name; i++) { v = symbol_ref(p[i].name); n = make_primitive(&p[i]); if (Apply_magic < 0 && !strcmp(p[i].name, "apply")) Apply_magic = prim_slot(n); if (Callcc_magic < 0 && !strcmp(p[i].name, "call/cc")) Callcc_magic = prim_slot(n); Environment = extend(v, n, Environment); } } cell get_args(char **argv) { int i; cell a, n; if (argv[0] == NULL) return Argv = NIL; a = cons(NIL, NIL); save(a); for (i = 0; argv[i] != NULL; i++) { n = make_string(argv[i], strlen(argv[i])); car(a) = n; if (argv[i+1] != NULL) { n = cons(NIL, NIL); cdr(a) = n; a = cdr(a); } } return Argv = unsave(1); } #ifndef EXTENSIONS #define EXTENSIONS #endif /* Extension prototypes; add your own here. */ void curs_init(void); void sys_init(void); void csv_init(void); void make_initial_env(void) { cell new; Environment = cons(NIL, NIL); Environment = extend(symbol_ref("**"), UNDEFINED, Environment); S_latest = cadr(Environment); Environment = extend(symbol_ref("*arguments*"), NIL, Environment); S_arguments = cadr(Environment); Environment = extend(symbol_ref("*epsilon*"), Epsilon, Environment); Environment = extend(symbol_ref("*extensions*"), NIL, Environment); S_extensions = cadr(Environment); Environment = extend(symbol_ref("*host-system*"), NIL, Environment); S_host_system = cadr(Environment); #ifdef unix box_value(S_host_system) = symbol_ref("unix"); #else #ifdef plan9 box_value(S_host_system) = symbol_ref("plan9"); #else box_value(S_host_system) = FALSE; #endif #endif Environment = extend(symbol_ref("*library-path*"), NIL, Environment); S_library_path = cadr(Environment); new = get_library_path(); box_value(S_library_path) = new; Environment = extend(symbol_ref("*loading*"), FALSE, Environment); S_loading = cadr(Environment); Apply_magic = -1; Callcc_magic = -1; add_primitives(NULL, Core_primitives); EXTENSIONS; Environment = cons(Environment, NIL); Program = TRUE; /* or rehash() will not work */ rehash(car(Environment)); } cell *GC_root[] = { &Program, &Environment, &Tmp, &Tmp_car, &Tmp_cdr, &Stack_bottom, &State_stack, &Acc, &Trace_list, &File_list, NULL }; cell *Image_vars[] = { &Environment, &S_and, &S_arguments, &S_arrow, &S_begin, &S_cond, &S_define, &S_define_syntax, &S_else, &S_extensions, &S_host_system, &S_if, &S_lambda, &S_latest, &S_library_path, &S_loading, &S_or, &S_quasiquote, &S_quote, &S_quote, &S_set_b, &S_unquote, &S_unquote_splicing, NULL }; void init(void) { strcpy(S9magic, "S9:"); strcat(S9magic, VERSION); s9_init(GC_root); image_vars(Image_vars); exponent_chars("eEdDfFlLsS"); Stack_bottom = NIL; State_stack = NIL; Tmp_car = NIL; Tmp_cdr = NIL; Tmp = NIL; Program = NIL; Proc_ptr = 0; Environment = NIL; Acc = NIL; Trace_list = NIL; Level = 0; Line_no = 1; Error_flag = 0; Intr_flag = 0; Load_level = 0; File_list = NIL; Displaying = 0; Quiet_mode = 0; Eval_stats = 0; S_arrow = symbol_ref("=>"); S_and = symbol_ref("and"); S_begin = symbol_ref("begin"); S_cond = symbol_ref("cond"); S_define = symbol_ref("define"); S_define_syntax = symbol_ref("define-syntax"); S_else = symbol_ref("else"); S_if = symbol_ref("if"); S_lambda = symbol_ref("lambda"); S_or = symbol_ref("or"); S_quasiquote = symbol_ref("quasiquote"); S_quote = symbol_ref("quote"); S_set_b = symbol_ref("set!"); S_unquote = symbol_ref("unquote"); S_unquote_splicing = symbol_ref("unquote-splicing"); make_initial_env(); reset_calltrace(); } void init_extensions(void) { cell e, n; char initproc[TOKEN_LENGTH+2]; char *s; char *s9 = "s9"; e = box_value(S_extensions); while (s9 || e != NIL) { if (e == NIL) { s = s9; s9 = NULL; } else { s = string(car(e)); } if (strlen(s)*2+1 >= TOKEN_LENGTH) fatal("init_extension(): procedure name too long"); sprintf(initproc, "%s:%s", s, s); n = find_symbol(initproc); if (n != NIL) { n = cons(n, NIL); eval(n); } if (e != NIL) e = cdr(e); } } void usage(int q) { prints("Usage: s9 [-hv?] [-i name|-] [-gqu] [-d image]"); prints(" [-e|-r expr] [-k size[m]]"); nl(); prints(" [-l prog] [-n size[m]]"); prints(" [[-f] prog [arg ...]] [-- [arg ...]]"); nl(); if (q) quit(1); } void long_usage(void) { cell x; nl(); prints("Scheme 9 from Empty Space by Nils M Holm, "); prints(VERSION); nl(); prints(""); #ifdef unix prints("unix"); #else #ifdef plan9 prints("plan 9"); #else prints("unknown platform"); #endif #endif #ifdef BITS_PER_WORD_64 prints(", 64 bits"); #else #ifdef BITS_PER_WORD_32 prints(", 32 bits"); #endif #endif x = binding_value(S_extensions); if (x == NIL) { prints(", no extensions"); } else { prints(", extensions: "); while (x != NIL) { print_form(car(x)); x = cdr(x); if (x != NIL) prints(", "); } } nl(); prints("library path: "); prints(string(binding_value(S_library_path))); nl(); prints("This program is in the public domain"); nl(); nl(); usage(0); nl(); prints("-h display this summary (also -v, -?)"); nl(); prints("-i name base name of image file (must be first option!)"); nl(); prints("-i - ignore image, load source file instead"); nl(); prints("-d file dump heap image to file and exit"); nl(); prints("-e expr evaluate expr, print value, do not enter REPL"); nl(); prints("-g print GC summaries (-gg = more)"); nl(); prints("-f file run program with args, then exit (-f is optional)"); nl(); prints("-k n[m] set vector limit to nK (or nM) cells"); nl(); prints("-l file load program (may be repeated)"); nl(); prints("-n n[m] set node limit to nK (or nM) nodes"); nl(); prints("-q be quiet (no banner, no prompt, exit on errors)"); nl(); prints("-r expr like -e, but don't print value (run for effect)"); nl(); prints("-u use unlimited node and vector memory"); nl(); prints("-- args bind remaining arguments to *arguments*"); nl(); nl(); } long get_size_k(char *s) { int c; long n; c = s[strlen(s)-1]; n = asctol(s); if (c == 'M' || c == 'm') n *= 1024L; else if (!isdigit(c)) usage(1); return n * 1024; } int main(int argc, char **argv) { int vgc = 0; int f_opt = 0; int arg_opt = 0; int do_loop = 1; int echo; char *argv0; char *s; if (argc > 2 && !strcmp(argv[1], "-i")) argv += 2; init(); handle_sigquit(); handle_sigterm(); argv0 = *argv++; load_library(argv0); init_extensions(); while (*argv != NULL && !f_opt && !arg_opt) { if (**argv != '-') break; (*argv)++; while (**argv) { switch (**argv) { case '-': arg_opt = 1; (*argv)++; break; case 'd': if (argv[1] == NULL) usage(1); s = dump_image(argv[1], S9magic); if (s != NULL) error(s, VOID); quit(Error_flag? 1: 0); break; case 'e': case 'r': echo = **argv == 'e'; if (argv[1] == NULL) usage(1); evalstr(argv[1], echo); argv++; *argv = &(*argv)[strlen(*argv)]; do_loop = 0; break; case 'f': if (argv[1] == NULL) usage(1); (*argv)++; f_opt = 1; break; case 'g': vgc++; (*argv)++; break; case 'k': if (argv[1] == NULL) usage(1); set_vector_limit(get_size_k(argv[1])); argv++; *argv += strlen(*argv); break; case 'l': if (argv[1] == NULL) usage(1); if (load(argv[1])) error("program file not found", make_string(argv[1], (int)strlen(argv[1]))); if (Error_flag) quit(1); argv++; *argv = &(*argv)[strlen(*argv)]; break; case 'n': if (argv[1] == NULL) usage(1); set_node_limit(get_size_k(argv[1])); argv++; *argv += strlen(*argv); break; case 'q': Quiet_mode = 1; (*argv)++; break; case 'u': set_node_limit(0); set_vector_limit(0); break; case 'h': case 'v': case '?': long_usage(); quit(0); break; default: usage(1); break; } } argv++; } if (do_loop == 0) return 0; gc_verbosity(vgc % 3); if (argv[0] != NULL && !arg_opt) { box_value(S_arguments) = get_args(argv+1); Quiet_mode = 1; if (load(argv[0])) error("program file not found", make_string(argv[0], (int)strlen(argv[0]))); quit(Error_flag); } box_value(S_arguments) = get_args(argv); if (!Quiet_mode) prints("Scheme 9 from Empty Space\n"); repl(); return 0; } s9/ABOUT000644 001751 001751 00000001771 12033053431 011616 0ustar00nmhnmh000000 000000 ____ ____ ____ ____ ____ / ___)/ __ \| __)| __)/ ___) Scheme 9 from Empty Space \___ \\__ /| __)| __)\___ \ Yet another implementation (____/(___/ |_| |____)(____/ of an interesting language This branch of S9fES is a hack. When something is broken or missing, fix it. Do with the code whatever you want, it is neither "mine" nor "yours". Rip it apart, make something new out of it, claim it is yours, re-license it, sell it, give it away, do not even tell me about it. This is all fine by me. Freedom cannot be possessed. Wherever there is freedom, it belongs to all. Being a hack, in this case, does not mean that the code is fragile. Au contraire. The S9 interpreter has been running large amounts of code for very long times without breaking, and I trust it to run even the most critical programs. It does mean, though, that when it *does* break, you are on your own. I have been hacking it for fun and may or may not consider fixing any bugs reported to me. Nils M Holm s9/s9.scm000644 001751 001751 00000105415 12750612524 012072 0ustar00nmhnmh000000 000000 ;; ;; Scheme 9 from Empty Space, Refactored ;; By Nils M Holm 2007-2015 ;; In the public domain ;; ;; Some obvious procedures first (define (void) (if #f #f)) (define call-with-current-continuation call/cc) ;; Auxiliary definitions, will be redefined later (define append append2) ; There is no LET or LETREC yet, so (define-syntax (let bindings . exprs) ((lambda (split) ((lambda (tmp-split) (set! split tmp-split) (apply (lambda (vars args) (append (list (append (list 'lambda) (append (list vars) exprs))) args)) (split bindings '() '()))) (lambda (bind* vars args) (if (null? bind*) (list vars args) (split (cdr bind*) (cons (caar bind*) vars) (cons (cadr (car bind*)) args)))))) #f)) (define (map-car f a) (let ((mapcar1 #f)) (let ((tmp-mapcar1 (lambda (a) (if (null? a) '() (cons (f (car a)) (mapcar1 (cdr a))))))) (set! mapcar1 tmp-mapcar1) (mapcar1 a)))) (define (map f a b) (let ((map2 #f)) (let ((tmp-map2 (lambda (a b) (if (null? a) '() (cons (f (car a) (car b)) (map2 (cdr a) (cdr b))))))) (set! map2 tmp-map2) (map2 a b)))) (define-syntax (letrec bindings . exprs) (let ((append3 (lambda (a b c) (append a (append b c)))) (tmps (map-car (lambda (x) (gensym)) bindings)) (vars (map-car car bindings)) (args (map-car cadr bindings))) (let ((undefineds (map-car (lambda (v) (list v #f)) vars)) (tmp-bindings (map list tmps args)) (updates (map (lambda (v t) (list 'set! v t)) vars tmps))) (list 'let undefineds (append3 '(let) (list tmp-bindings) (append updates exprs)))))) ;; Type predicates (define number? real?) (define (port? x) (or (input-port? x) (output-port? x))) ;; Equivalence predicates (define (equal? a b) (cond ((eq? a b)) ((and (pair? a) (pair? b)) (and (equal? (car a) (car b)) (equal? (cdr a) (cdr b)))) ((string? a) (and (string? b) (string=? a b))) ((vector? a) (and (vector? b) (equal? (vector->list a) (vector->list b)))) (else (eqv? a b)))) ;; List procedures (define (list? x) (letrec ((l? (lambda (x y) (cond ((eq? x y) #f) ((null? x) #t) ((pair? x) (or (null? (cdr x)) (and (pair? (cdr x)) (l? (cddr x) (cdr y))))) (else #f))))) (or (null? x) (and (pair? x) (l? (cdr x) x))))) (define (assoc x a) (cond ((null? a) #f) ((equal? (caar a) x) (car a)) (else (assoc x (cdr a))))) (define (member x a) (cond ((null? a) #f) ((equal? (car a) x) a) (else (member x (cdr a))))) ; Auxiliary functions for FOLD-LEFT, FOLD-RIGHT, MAP (define (map-car f a) (letrec ((mapcar1 (lambda (a r) (if (null? a) (reverse r) (mapcar1 (cdr a) (cons (f (car a)) r)))))) (mapcar1 a '()))) (define car-of (let ((map-car map-car)) (lambda (a*) (map-car car a*)))) (define cdr-of (let ((map-car map-car)) (lambda (a*) (map-car cdr a*)))) (define (any-null a*) (memq '() a*)) (define fold-left (let ((car-of car-of) (cdr-of cdr-of) (any-null any-null)) (lambda (f b . a*) (letrec ((fold (lambda (a* r) (if (any-null a*) r (fold (cdr-of a*) (apply f r (car-of a*))))))) (if (null? a*) (error "fold-left: too few arguments") (fold a* b)))))) (define fold-right (let ((car-of car-of) (cdr-of cdr-of) (any-null any-null) (map-car map-car)) (lambda (f b . a*) (letrec ((foldr (lambda (a* r) (if (any-null a*) r (foldr (cdr-of a*) (apply f (append2 (car-of a*) (list r)))))))) (if (null? a*) (error "fold-right: too few arguments") (foldr (map-car reverse a*) b)))))) (define append (let ((append2 append2)) (letrec ((foldr-app (lambda (a) (cond ((null? a) '()) ((and (pair? a) (not (pair? (car a))) (null? (cdr a))) (car a)) (else (append2 (car a) (foldr-app (cdr a)))))))) (lambda a (foldr-app a))))) (define (list-ref x n) (car (list-tail x n))) (define map (let ((car-of car-of) (cdr-of cdr-of) (any-null any-null)) (lambda (f . a*) (letrec ((map2 (lambda (a* r) (if (any-null a*) (reverse r) (map2 (cdr-of a*) (cons (apply f (car-of a*)) r)))))) (if (null? a*) (error "map: too few arguments") (map2 a* '())))))) (define (for-each f . a*) (if (null? a*) (error "for-each: too few arguments") (apply map f a*)) (void)) ;; Arithmetic procedures (define gcd (let ((fold-left fold-left)) (lambda a (letrec ((gcd2 (lambda (a b) (cond ((zero? b) a) ((zero? a) b) ((< a b) (gcd2 a (remainder b a))) (else (gcd2 b (remainder a b))))))) (fold-left gcd2 0 (map abs a)))))) (define lcm (let ((fold-left fold-left)) (lambda a (letrec ((lcm2 (lambda (a b) (let ((cd (gcd a b))) (* cd (* (quotient a cd) (quotient b cd))))))) (fold-left lcm2 1 (map abs a)))))) (define (modulo a b) (let ((rem (remainder a b))) (cond ((zero? rem) 0) ((eq? (negative? a) (negative? b)) rem) (else (+ b rem))))) ;; Input/output procedures (define (newline . port) (apply write-char #\newline port)) (define (call-with-input-file file proc) (let ((f (open-input-file file))) (let ((r (proc f))) (close-input-port f) r))) (define (call-with-output-file file proc) (let ((f (open-output-file file))) (let ((r (proc f))) (close-output-port f) r))) (define with-input-from-file (let ((set-input-port! set-input-port!)) (lambda (file thunk) (let ((outer-port (current-input-port)) (new-port (open-input-file file))) (set-input-port! new-port) (let ((r (thunk))) (close-input-port new-port) (set-input-port! outer-port) r))))) (define with-output-to-file (let ((set-output-port! set-output-port!)) (lambda (file thunk) (let ((outer-port (current-output-port)) (new-port (open-output-file file))) (set-output-port! new-port) (let ((r (thunk))) (close-output-port new-port) (set-output-port! outer-port) r))))) ;; Quasiquote Expander (define-syntax (quasiquote tmpl) (letrec ((qq-cons (lambda (a b) (cond ((and (pair? a) (eq? 'unquote-splicing (car a))) (list 'append (cadr a) b)) (else (list 'cons a b))))) (qq-expand-1 (lambda (x) (cond ((vector? x) (list 'list->vector (qq-expand-1 (vector->list x)))) ((not (pair? x)) (list 'quote x)) ((eq? 'unquote (car x)) (cadr x)) ((eq? 'unquote-splicing (car x)) x) (else (qq-cons (qq-expand-1 (car x)) (qq-expand-1 (cdr x))))))) (qq-expand (lambda (tmpl q) (let ((embedded-qq '())) (letrec ((extract-nested-qq (lambda (tmpl q) (cond ((not (pair? tmpl)) tmpl) ((or (eq? (car tmpl) 'unquote) (eq? (car tmpl) 'unquote-splicing)) (if (not q) (error "quasiquote: extra unquote/unquote-splicing")) (if (and (pair? (cdr tmpl)) (null? (cddr tmpl))) (list (car tmpl) (extract-nested-qq (cadr tmpl) #f)) (error (string-append (symbol->string (car tmpl)) ": wrong number of arguments") tmpl))) ((eq? 'quasiquote (car tmpl)) (if q (error "quasiquote: may not be nested")) (if (and (pair? (cdr tmpl)) (null? (cddr tmpl))) (let ((g (gensym))) (set! embedded-qq (cons (list g (qq-expand (cadr tmpl) #t)) embedded-qq)) g) (error "quasiquote: wrong number of arguments" tmpl))) (else (cons (extract-nested-qq (car tmpl) q) (extract-nested-qq (cdr tmpl) q))))))) (let ((tmpl (extract-nested-qq tmpl q))) (if (null? embedded-qq) (qq-expand-1 tmpl) (list 'let embedded-qq (qq-expand-1 tmpl))))))))) (qq-expand tmpl #t))) ;; Derived Syntax ; LET/LET*/LETREC helper (define (check-bindings who b opt-arg) (cond ((null? b)) ((and (pair? b) (pair? (car b)) (symbol? (caar b)) (pair? (cdar b)) (or (null? (cddar b)) (and opt-arg (pair? (cddar b)) (null? (cdddar b))))) (check-bindings who (cdr b) opt-arg)) (else (error (string-append who ": invalid syntax") b)))) (define (split-bindings clauses) (letrec ((split3 (lambda (clauses vars args opt) (cond ((null? clauses) (list (reverse vars) (reverse args) (reverse opt))) (else (split3 (cdr clauses) (cons (caar clauses) vars) (cons (cadar clauses) args) (if (null? (cddar clauses)) (cons (caar clauses) opt) (cons (caddar clauses) opt)))))))) (split3 clauses '() '() '()))) ; Now that the QQ expander is here, define a ; clean version of LET (including named LET). ; Can't name it LET yet, because it uses LET. (define-syntax %full-let (let ((check-bindings check-bindings) (split-bindings split-bindings)) (lambda (a1 a2 . a3) (if (symbol? a1) (if (null? a3) (error "named let: missing body" `(let ,a1 ,a2 ,@a3)) (begin (check-bindings "let" a2 #f) (let ((va (split-bindings a2))) (let ((v (car va)) (a (cadr va))) `((letrec ((,a1 (lambda ,v ,@a3))) ,a1) ,@a))))) (begin (check-bindings "let" a1 #f) (let ((va (split-bindings a1))) (let ((v (car va)) (a (cadr va))) `((lambda ,v ,a2 ,@a3) ,@a)))))))) (define-syntax let %full-let) ; Also define a clean version of LETREC. (define-syntax %clean-letrec (let ((check-bindings check-bindings) (split-bindings split-bindings)) (lambda (bindings expr . exprs) (check-bindings "letrec" bindings #f) (let ((va (split-bindings bindings))) (let ((tmps (map (lambda (x) (gensym)) bindings)) (vars (car va)) (args (cadr va))) (let ((undefineds (map (lambda (v) (list v #f)) vars)) (tmp-bindings (map (lambda (t a) (list t a)) tmps args)) (updates (map (lambda (v t) (list 'set! v t)) vars tmps))) `(let ,undefineds (let ,tmp-bindings ,@updates ,expr ,@exprs)))))))) (define-syntax letrec %clean-letrec) (define-syntax let* (let ((check-bindings check-bindings)) (lambda (bindings expr . exprs) (letrec ((nest-let (lambda (b) (if (null? (cdr b)) `(let (,(car b)) ,@(cons expr exprs)) `(let (,(car b)) ,(nest-let (cdr b))))))) (check-bindings "let*" bindings #f) (if (null? bindings) `(let () ,expr ,@exprs) (nest-let bindings)))))) (define-syntax (case key . clauses) (letrec ((gen-clauses (lambda (k c*) (cond ((null? c*) '()) ((or (not (pair? c*)) (not (pair? (car c*))) (not (pair? (cdar c*)))) (error "case: syntax error" c*)) ((null? (cdr c*)) (if (eq? 'else (caar c*)) `((else ,@(cdar c*))) `(((memv ,k ',(caar c*)) ,@(cdar c*))))) (else `(((memv ,k ',(caar c*)) ,@(cdar c*)) ,@(gen-clauses k (cdr c*)))))))) (let ((k (gensym))) `(let ((,k ,key)) (cond ,@(gen-clauses k clauses)))))) (define-syntax do (let ((check-bindings check-bindings) (split-bindings split-bindings)) (lambda (var-clauses test . body) (if (or (not (pair? test)) (not (list? (cdr test)))) (error "do: invalid syntax" test)) (check-bindings "do" var-clauses #t) (let ((loop (gensym)) (var+init+step (split-bindings var-clauses))) (let ((v (car var+init+step)) (i (cadr var+init+step)) (s (caddr var+init+step))) `(letrec ((,loop (lambda ,v (if ,(car test) (begin ,@(cdr test)) (begin ,@body (,loop ,@s)))))) (,loop ,@i))))))) (define-syntax (delay expr) `(let ((value #f)) (lambda () (if value (car value) (let ((x ,expr)) (if value (car value) (begin (set! value (list x)) (car value)))))))) (define (force x) (x)) ;; Real number arithmetics (define (expt x y) (letrec ((square (lambda (x) (* x x))) (expt2 (lambda (x y) (cond ((zero? y) 1) ((even? y) (square (expt2 x (quotient y 2)))) (else (* x (square (expt2 x (quotient y 2))))))))) (cond ((negative? y) (/ (expt (exact->inexact x) (- y)))) ((zero? x) (if (inexact? y) (if (positive? y) 0 (/ 1 0)) (expt2 x y))) ((integer? y) (expt2 x y)) (else (exp (* y (log x))))))) (define (round x) (let ((x+ (+ 0.5 x))) (let ((rx (floor x+))) (if (and (odd? (inexact->exact rx)) (= x+ rx)) (- rx 1) rx)))) (define (exp x) (letrec ((e-series (lambda (x i x^y y! r last) (if (<= (abs (- last r)) *epsilon*) r (e-series x (+ 1 i) (* x^y x) (* y! (+ 1 i)) (+ r (/ x^y y!)) r))))) (if (>= x 2.0) (let ((e^x/2 (exp (/ x 2)))) (* e^x/2 e^x/2)) (+ 1 (e-series x 1 x 1 0.0 1.0))))) (define (log x) (letrec ((l-series6 (lambda (x y x^y r last lim) (cond ((and lim (zero? lim)) r) ((<= (abs (- last r)) *epsilon*) (* 2 r)) (else (l-series6 x (+ 2 y) (* x^y x x) (+ r (/ x^y y)) r (if lim (- lim 1) lim)))))) (l-series (lambda (x y r last lim) (let ((x (/ (- x 1) (+ x 1)))) (l-series6 x y x r last lim))))) (cond ((negative? x) (/ 1.0 0)) ((< 0.1 x 5) (l-series x 1 0.0 1.0 #f)) (else (let ((approx (l-series x 1 0.0 1.0 5))) (let ((a (/ x (exp approx)))) (+ approx (log a)))))))) ; auxiliary definitions for SIN, COS, TAN, ATAN (define pi 3.141592653589793238462643383279502884197169399375105820974944) (define pi/4 (/ pi 4)) (define pi/2 (/ pi 2)) (define 3pi/4 (+ pi/2 pi/4)) (define 3pi/2 (+ pi pi/2)) (define 5pi/4 (+ pi pi/4)) (define 7pi/4 (+ pi 3pi/4)) (define 2pi (+ pi pi)) (define ->circle (let ((2pi 2pi)) (lambda (x) (let* ((x+ (abs x)) (d (* 2pi (floor (/ x+ 2pi)))) (x+ (- x+ d))) (if (negative? x) (- 2pi x+) x+))))) ; used by SIN, COS, ATAN, and EXP (define (fact2 n m) (if (< n 2) m (let ((k (quotient n 2))) (* (fact2 k m) (fact2 (- n k) (+ m k)))))) (define sine-series (let ((fact2 fact2)) (lambda (x y r add last) (if (<= (abs (- last r)) *epsilon*) r (sine-series x (+ 2 y) ((if add + -) r (/ (expt x y) (fact2 y 1))) (not add) r))))) (define cos (let ((->circle ->circle) (sine-series sine-series) (pi pi) (pi/2 pi/2) (3pi/2 3pi/2) (2pi 2pi)) (lambda (x) (let ((x (->circle x))) (cond ((= 0 x) (if (inexact? x) 1.0 1)) ((= pi/2 x) 0.0) ((= pi x) -1.0) ((= 3pi/2 x) 0.0) ((<= 0 x pi/2) (sine-series x 2 1.0 #f 0)) ((<= pi/2 x pi) (- (sine-series (- pi x) 2 1.0 #f 0))) ((<= pi x 3pi/2) (- (sine-series (- x pi) 2 1.0 #f 0))) (else (sine-series (- 2pi x) 2 1.0 #f 0))))))) (define sin (let ((->circle ->circle) (sine-series sine-series) (pi pi) (pi/2 pi/2) (3pi/2 3pi/2) (2pi 2pi)) (lambda (x) (let ((x (->circle x))) (cond ((= 0 x) (if (inexact? x) 0.0 0)) ((= pi/2 x) 1.0) ((= pi x) 0.0) ((= 3pi/2 x) -1.0) (else (let ((z (cond ((<= 0 x pi/2) x) ((<= pi/2 x pi) (- pi x)) ((<= pi x 3pi/2) (- x pi)) (else (- 2pi x))))) (if (> x pi) (- (sine-series z 3 z #f 0)) (sine-series z 3 z #f 0))))))))) (define tan (let ((->circle ->circle) (pi pi) (pi/4 pi/4) (3pi/4 3pi/4) (5pi/4 5pi/4) (7pi/4 7pi/4)) (lambda (x) (let ((x (->circle x))) (cond ((or (= x 0) (= x pi)) (if (inexact? x) 0.0 0)) ((or (= x pi/4) (= x 5pi/4)) 1.0) ((or (= x 3pi/4) (= x 7pi/4)) -1.0) (else (/ (sin x) (cos x)))))))) (define atan (let ((pi/2 pi/2)) (letrec ((at-series (lambda (x y r last) (if (<= (abs (- last r)) *epsilon*) r (at-series x (+ 1 y) (+ r (* (/ (* (expt 2 (+ y y)) (expt (fact2 y 1) 2)) (fact2 (+ y y 1) 1)) (/ (expt x (+ y y 1)) (expt (+ 1 (* x x)) (+ 1 y))))) r))))) (lambda (x) (cond ((negative? x) (- (atan (- x)))) ((> x 1) (- pi/2 (atan (/ x)))) (else (at-series x 0.0 0 1))))))) (define (asin x) (cond ((= 1 x) (* 2 (atan x))) ((negative? x) (- (asin (- x)))) (else (atan (/ x (sqrt (- 1 (* x x)))))))) (define acos (let ((pi pi) (pi/2 pi/2)) (lambda (x) (cond ((= -1 x) pi) ((= 1 x) 0) (else (- pi/2 (asin x))))))) (define (sqrt square) (letrec ((sqrt2 (lambda (x last) (if (<= (abs (- last x)) *epsilon*) x (sqrt2 (/ (+ x (/ square x)) 2) x))))) (if (negative? square) (error "sqrt: negative argument" square) (sqrt2 square 0)))) ; Used by NUMBER->STRING and STRING->NUMBER (define (number-of-digits n r) (if (zero? n) (if (zero? r) 1 r) (number-of-digits (quotient n 10) (+ 1 r)))) (define number->string (let ((number-of-digits number-of-digits)) (lambda (n . radix) (letrec ((digits (list->vector (string->list "0123456789abcdefghijklmnopqrstuvwxyz"))) (conv (lambda (n rdx res) (if (zero? n) (if (null? res) '(#\0) res) (conv (quotient n rdx) rdx (cons (vector-ref digits (remainder n rdx)) res))))) (conv-int (lambda (n rdx) (if (negative? n) (list->string (cons #\- (conv (abs n) rdx '()))) (list->string (conv n rdx '()))))) (conv-sci-real (lambda (m e) (let ((m-str (conv-int m 10)) (e-str (conv-int e 10)) (i (if (negative? m) 2 1))) (let ((k (string-length m-str))) (string-append (substring m-str 0 i) "." (if (= k i) "0" (substring m-str i k)) "e" (if (>= e 0) "+" "") e-str))))) (zeroes (lambda (n) (let loop ((n n) (z '())) (if (positive? n) (loop (- n 1) (cons #\0 z)) (list->string z))))) (conv-expanded-real (lambda (n expn digits) (let ((m (abs n)) (offset (+ expn digits))) (string-append (if (negative? n) "-" "") (cond ((negative? offset) "0.") ((zero? offset) "0") (else "")) (zeroes (- offset)) (let ((m-str (conv-int m 10))) (if (<= 0 offset digits) (string-append (substring m-str 0 offset) "." (substring m-str offset digits) (if (= offset digits) "0" "")) m-str)) (if (> offset digits) (string-append (zeroes (- offset digits)) ".0") ""))))) (conv-real (lambda (n) (let ((m (mantissa n)) (e (exponent n))) (let ((d (number-of-digits m 0))) (if (< -4 (+ e d) 10) (conv-expanded-real m e d) (conv-sci-real m (+ e d -1))))))) (get-radix (lambda () (cond ((null? radix) 10) ((<= 2 (car radix) 36) (car radix)) (else (error "number->string: invalid radix" (car radix))))))) (let ((r (get-radix))) (cond ((not (or (exact? n) (= 10 r))) (error "number->string: real number needs a radix of 10" n)) ((exact? n) (conv-int n r)) (else (conv-real n)))))))) (define string->number (let ((number-of-digits number-of-digits) (make-inexact #f) (make-exact #f)) (lambda (str . radix) (letrec ((digits (string->list "0123456789abcdefghijklmnopqrstuvwxyz")) (value-of-digit (lambda (x) (letrec ((v (lambda (x d n) (cond ((null? d) 36) ((char=? (car d) x) n) (else (v x (cdr d) (+ n 1))))))) (v (char-downcase x) digits 0)))) (exponent-mark (lambda (c) (memv c '(#\d #\D #\e #\E #\f #\F #\l #\L #\s #\S)))) (make-result cons) (value car) (rest cdr) (FAILED '(#f . #f)) (failed? (lambda (res) (eq? #f (cdr res)))) (ok? (lambda (res) (not (eq? #f (cdr res))))) (conv3 (lambda (lst val rdx) (if (null? lst) (make-result val '()) (let ((dval (value-of-digit (car lst)))) (if (< dval rdx) (conv3 (cdr lst) (+ (value-of-digit (car lst)) (* val rdx)) rdx) (make-result val lst)))))) (conv (lambda (lst rdx) (if (null? lst) FAILED (conv3 lst 0 rdx)))) (conv-int (lambda (lst rdx) (cond ((null? lst) FAILED) ((char=? (car lst) #\+) (conv (cdr lst) rdx)) ((char=? (car lst) #\-) (let ((r (conv (cdr lst) rdx))) (if (ok? r) (make-result (- (value r)) (rest r)) FAILED))) (else (conv lst rdx))))) (make-fract (lambda (x) (let ((d (number-of-digits x -1))) ; 123 --> 0.123 (- (/ x (expt 10.0 d)) 1.0)))) (make-real (lambda (int fract expn) (let ((v (* (+ 0.0 (abs int) (make-fract fract)) (expt 10.0 expn)))) (if (negative? int) (- v) v)))) (conv-exponent (lambda (int fract lst) (if (null? lst) FAILED (let ((exp-part (conv-int lst 10))) (if (failed? exp-part) FAILED (make-result (make-real int fract (value exp-part)) (rest exp-part))))))) (conv-decimals (lambda (int lst) (cond ((null? lst) (make-result (exact->inexact int) '())) ; trailing #\. ((exponent-mark (car lst)) (conv-exponent int 10 (cdr lst))) (else (let ((fract-part (conv3 lst 1 10))) (if (null? (rest fract-part)) (make-result (make-real int (value fract-part) 0) '()) (if (exponent-mark (car (rest fract-part))) (conv-exponent int (value fract-part) (cdr (rest fract-part))) FAILED))))))) (assert-radix-ten (lambda (rdx) (cond ((= 10 rdx)) ((null? radix) #f) (else (error (string-append "string->number: real number" " needs a radix of 10")))))) (mantissa? (lambda (x) (cond ((null? x) #f) ((char-numeric? (car x)) #t) ((exponent-mark (car x)) #f) (else (mantissa? (cdr x)))))) (conv-real (lambda (lst rdx) (let ((int-part (conv-int lst rdx))) (cond ((failed? int-part) FAILED) ((and (zero? (value int-part)) ; "" or "e" (not (mantissa? lst))) FAILED) ((null? (rest int-part)) int-part) ((exponent-mark (car (rest int-part))) (assert-radix-ten rdx) (conv-exponent (value int-part) 10 (cdr (rest int-part)))) ((char=? #\. (car (rest int-part))) (assert-radix-ten rdx) (conv-decimals (value int-part) (cdr (rest int-part)))) (else FAILED))))) (replace-inexact-digits! (lambda (a) (cond ((null? a)) ((char=? #\# (car a)) (set-car! a #\5) (set! make-inexact #t) (replace-inexact-digits! (cdr a))) (else (replace-inexact-digits! (cdr a)))))) (get-radix (lambda () (cond ((null? radix) 10) ((<= 2 (car radix) 36) (car radix)) (else (error "string->number: invalid radix" (car radix))))))) (set! make-inexact #f) (set! make-exact #f) (let ((radix (get-radix)) (lst (string->list str))) (if (and (> (string-length str) 1) (char=? #\# (car lst))) (let ((mod (cadr lst))) (set! lst (cddr lst)) (cond ((char=? mod #\d)) ((char=? mod #\e) (set! make-exact #t)) ((char=? mod #\i) (set! make-inexact #t)) ((char=? mod #\b) (set! radix 2)) ((char=? mod #\o) (set! radix 8)) ((char=? mod #\x) (set! radix 16)) (else (set! lst '()))))) (if (or (null? lst) (memv (car lst) '(#\+ #\- #\.)) (char-numeric? (car lst))) (replace-inexact-digits! lst)) (let ((r (cond ((null? lst) FAILED) ((char=? #\- (car lst)) (conv-real (cdr lst) radix)) (else (conv-real lst radix))))) (if (null? (rest r)) (let ((v (if (char=? #\- (car lst)) (- (value r)) (value r)))) (cond (make-inexact (exact->inexact v)) (make-exact (if (integer? v) (inexact->exact v) #f)) (else v))) #f))))))) ;; Utilities (define (print . x*) (letrec ((p (lambda (x* first) (cond ((not (null? x*)) (if (not first) (write-char #\space)) (write (car x*)) (p (cdr x*) #f)))))) (p x* #t) (newline))) (define (locate-file file) (letrec ((split (lambda (s) (let loop ((in (string->list s)) (tmp '()) (out '())) (cond ((null? in) (if (null? tmp) out (reverse (cons (list->string (reverse tmp)) out)))) ((char=? #\: (car in)) (loop (cdr in) '() (cons (list->string (reverse tmp)) out))) (else (loop (cdr in) (cons (car in) tmp) out))))))) (let loop ((path (split *library-path*))) (and (not (null? path)) (let ((full-path (string-append (car path) "/" file))) (if (file-exists? full-path) full-path (loop (cdr path)))))))) (define load-from-library (let ((locate-file locate-file)) (lambda (file) (let ((full-path (locate-file file)) (do-load (lambda (file) (begin (if (not *loading*) (begin (display "; loading from ") (display file) (newline))) (load file))))) (if full-path (do-load full-path) (let ((full-path (locate-file (string-append file ".scm")))) (if full-path (do-load full-path) (error "cannot locate file" file)))))))) (define-syntax (require-extension . x*) (define (isect a b) (cond ((null? a) '()) ((memq (car a) b) (cons (car a) (isect (cdr a) b))) (else (isect (cdr a) b)))) (do ((x* x* (cdr x*)) (na '())) ((null? x*) (if (not (null? na)) (error "extension(s) required, but not compiled-in" (reverse! na)))) (cond ((memq (car x*) *extensions*)) ((and (pair? (car x*)) (eq? 'or (caar x*)) (not (null? (isect (cdar x*) *extensions*))))) (else (set! na (cons (car x*) na)))))) s9/s9core.h000644 001751 001751 00000034336 13201114013 012371 0ustar00nmhnmh000000 000000 /* * S9core Toolkit, Mk IIIc * By Nils M Holm, 2007-2017 * In the public domain */ #define S9_VERSION "20161130" /* * Ugly prelude to figure out if * we are compiling on a Un*x system. */ #ifdef __NetBSD__ #ifndef unix #define unix #endif #endif #ifdef __unix #ifndef unix #define unix #endif #endif #ifdef __linux #ifndef unix #define unix #endif #endif #ifdef __GNUC__ #ifndef unix #define unix #endif #endif #ifdef __clang__ #ifndef unix #define unix #endif #endif #ifndef unix #ifndef plan9 #error "Either 'unix' or 'plan9' must be #defined." #endif #endif /* * Tell later MSC compilers to let us use the standard CLIB API. * Blake McBride < b l a k e @ m c b r i d e . n a m e > */ #ifdef _MSC_VER #if _MSC_VER > 1200 #ifndef _CRT_SECURE_NO_DEPRECATE #define _CRT_SECURE_NO_DEPRECATE #endif #endif #ifndef _POSIX_ #define _POSIX_ #endif #endif #ifdef plan9 #include #include #include #include #define bye(x) exits((x)? "error": NULL) #define ptrdiff_t int #endif #ifdef unix #include #include #include #include #include #define bye(x) exit((x)? EXIT_FAILURE: EXIT_SUCCESS); #endif /* An "s9_cell" must be large enough to hold a pointer */ #define s9_cell ptrdiff_t /* Default memory limit in K-nodes, 0 = none */ #define S9_NODE_LIMIT 14013 #define S9_VECTOR_LIMIT 14013 /* Initial pool size in nodes */ #define S9_INITIAL_SEGMENT_SIZE 32768 /* Primitive segment size (slots) */ #define S9_PRIM_SEG_SIZE 256 /* Maximum number of open I/O ports */ #define S9_MAX_PORTS 32 /* Pick one ... */ /* #define S9_BITS_PER_WORD_64 */ /* #define S9_BITS_PER_WORD_32 */ /* #define S9_BITS_PER_WORD_16 */ /* ... or try some magic constants (unreliable, though) ... */ #ifdef __amd64__ #define S9_BITS_PER_WORD_64 #endif #ifdef __amd64 #define S9_BITS_PER_WORD_64 #endif #ifdef __x86_64__ #define S9_BITS_PER_WORD_64 #endif #ifdef __x86_64 #define S9_BITS_PER_WORD_64 #endif /* ... or assume a reasonable default */ #ifndef S9_BITS_PER_WORD_16 #ifndef S9_BITS_PER_WORD_32 #ifndef S9_BITS_PER_WORD_64 #define S9_BITS_PER_WORD_32 #endif #endif #endif /* * Node tags */ #define S9_ATOM_TAG 0x01 /* Atom, car = type, CDR = next */ #define S9_MARK_TAG 0x02 /* Mark */ #define S9_STATE_TAG 0x04 /* State */ #define S9_VECTOR_TAG 0x08 /* Vector, car = type, CDR = content */ #define S9_PORT_TAG 0x10 /* Atom is an I/O port (with ATOM_TAG) */ #define S9_USED_TAG 0x20 /* Port: used flag */ #define S9_LOCK_TAG 0x40 /* Port: locked (do not close) */ #define S9_CONST_TAG 0x80 /* Node is immutable */ /* * Integer segment specs */ #ifdef S9_BITS_PER_WORD_64 #define S9_DIGITS_PER_CELL 18 #define S9_INT_SEG_LIMIT 1000000000000000000LL #define S9_MANTISSA_SEGMENTS 1 #else #ifdef S9_BITS_PER_WORD_32 #define S9_DIGITS_PER_CELL 9 #define S9_INT_SEG_LIMIT 1000000000L #define S9_MANTISSA_SEGMENTS 2 #else #ifdef S9_BITS_PER_WORD_16 #define S9_DIGITS_PER_CELL 4 #define S9_INT_SEG_LIMIT 10000 #define S9_MANTISSA_SEGMENTS 2 #else #error "S9_BITS_PER_WORD_* undefined (this should not happen)" #endif #endif #endif /* * Real number mantissa size */ #define S9_MANTISSA_SIZE (S9_MANTISSA_SEGMENTS * S9_DIGITS_PER_CELL) /* * Special objects */ #define s9_special_p(x) ((x) < 0) #define S9_NIL (-1) #define S9_TRUE (-2) #define S9_FALSE (-3) #define S9_END_OF_FILE (-4) #define S9_UNDEFINED (-5) #define S9_UNSPECIFIC (-6) #define S9_VOID (-7) /* * Types */ #define S9_T_ANY (-10) #define S9_T_BOOLEAN (-11) #define S9_T_CHAR (-12) #define S9_T_INPUT_PORT (-13) #define S9_T_INTEGER (-14) #define S9_T_LIST (-17) #define S9_T_OUTPUT_PORT (-15) #define S9_T_PAIR (-16) #define S9_T_PRIMITIVE (-18) #define S9_T_FUNCTION (-19) #define S9_T_REAL (-20) #define S9_T_STRING (-21) #define S9_T_SYMBOL (-22) #define S9_T_SYNTAX (-23) #define S9_T_VECTOR (-24) #define S9_T_CONTINUATION (-25) #define S9_T_NONE (-99) #define S9_USER_SPECIALS (-100) /* * Structures */ struct S9_counter { int n, n1k, n1m, n1g, n1t; }; #define s9_counter struct S9_counter struct S9_primitive { char *name; s9_cell (*handler)(s9_cell expr); int min_args; int max_args; /* -1 = variadic */ int arg_types[3]; }; #define S9_PRIM struct S9_primitive /* * I/O */ #define s9_nl() s9_prints("\n") /* * Access to fields of atoms */ #define tag(n) (S9_tag[n]) #define s9_string(n) ((char *) &Vectors[S9_cdr[n]]) #define s9_string_len(n) (Vectors[S9_cdr[n] - 1]) #define s9_symbol_name(n) (string(n)) #define s9_symbol_len(n) (string_len(n)) #define s9_vector(n) (&Vectors[S9_cdr[n]]) #define s9_vector_link(n) (Vectors[S9_cdr[n] - 3]) #define s9_vector_index(n) (Vectors[S9_cdr[n] - 2]) #define s9_vector_size(k) (((k) + sizeof(s9_cell)-1) / sizeof(s9_cell) + 3) #define s9_vector_len(n) (vector_size(string_len(n)) - 3) #define s9_port_no(n) (cadr(n)) #define s9_char_value(n) (cadr(n)) #define s9_prim_slot(n) (cadr(n)) #define s9_prim_info(n) (&Primitives[prim_slot(n)]) /* * Nested lists */ #define s9_car(x) (S9_car[x]) #define s9_cdr(x) (S9_cdr[x]) #define s9_caar(x) (S9_car[S9_car[x]]) #define s9_cadr(x) (S9_car[S9_cdr[x]]) #define s9_cdar(x) (S9_cdr[S9_car[x]]) #define s9_cddr(x) (S9_cdr[S9_cdr[x]]) #define s9_caaar(x) (S9_car[S9_car[S9_car[x]]]) #define s9_caadr(x) (S9_car[S9_car[S9_cdr[x]]]) #define s9_cadar(x) (S9_car[S9_cdr[S9_car[x]]]) #define s9_caddr(x) (S9_car[S9_cdr[S9_cdr[x]]]) #define s9_cdaar(x) (S9_cdr[S9_car[S9_car[x]]]) #define s9_cdadr(x) (S9_cdr[S9_car[S9_cdr[x]]]) #define s9_cddar(x) (S9_cdr[S9_cdr[S9_car[x]]]) #define s9_cdddr(x) (S9_cdr[S9_cdr[S9_cdr[x]]]) #define s9_caaaar(x) (S9_car[S9_car[S9_car[S9_car[x]]]]) #define s9_caaadr(x) (S9_car[S9_car[S9_car[S9_cdr[x]]]]) #define s9_caadar(x) (S9_car[S9_car[S9_cdr[S9_car[x]]]]) #define s9_caaddr(x) (S9_car[S9_car[S9_cdr[S9_cdr[x]]]]) #define s9_cadaar(x) (S9_car[S9_cdr[S9_car[S9_car[x]]]]) #define s9_cadadr(x) (S9_car[S9_cdr[S9_car[S9_cdr[x]]]]) #define s9_caddar(x) (S9_car[S9_cdr[S9_cdr[S9_car[x]]]]) #define s9_cadddr(x) (S9_car[S9_cdr[S9_cdr[S9_cdr[x]]]]) #define s9_cdaaar(x) (S9_cdr[S9_car[S9_car[S9_car[x]]]]) #define s9_cdaadr(x) (S9_cdr[S9_car[S9_car[S9_cdr[x]]]]) #define s9_cdadar(x) (S9_cdr[S9_car[S9_cdr[S9_car[x]]]]) #define s9_cdaddr(x) (S9_cdr[S9_car[S9_cdr[S9_cdr[x]]]]) #define s9_cddaar(x) (S9_cdr[S9_cdr[S9_car[S9_car[x]]]]) #define s9_cddadr(x) (S9_cdr[S9_cdr[S9_car[S9_cdr[x]]]]) #define s9_cdddar(x) (S9_cdr[S9_cdr[S9_cdr[S9_car[x]]]]) #define s9_cddddr(x) (S9_cdr[S9_cdr[S9_cdr[S9_cdr[x]]]]) /* * Type predicates */ #define s9_eof_p(n) ((n) == S9_END_OF_FILE) #define s9_undefined_p(n) ((n) == S9_UNDEFINED) #define s9_unspecific_p(n) ((n) == S9_UNSPECIFIC) #define s9_boolean_p(n) \ ((n) == S9_TRUE || (n) == S9_FALSE) #define s9_constant_p(n) \ (!s9_special_p(n) && (tag(n) & S9_CONST_TAG)) #define s9_integer_p(n) \ (!s9_special_p(n) && (tag(n) & S9_ATOM_TAG) && car(n) == S9_T_INTEGER) #define s9_number_p(n) \ (!s9_special_p(n) && (tag(n) & S9_ATOM_TAG) && \ (car(n) == S9_T_REAL || car(n) == S9_T_INTEGER)) #define s9_primitive_p(n) \ (!s9_special_p(n) && (tag(n) & S9_ATOM_TAG) && \ car(n) == S9_T_PRIMITIVE) #define s9_function_p(n) \ (!s9_special_p(n) && (tag(n) & S9_ATOM_TAG) && \ car(n) == S9_T_FUNCTION) #define s9_continuation_p(n) \ (!s9_special_p(n) && (tag(n) & S9_ATOM_TAG) && \ car(n) == S9_T_CONTINUATION) #define s9_real_p(n) \ (!s9_special_p(n) && (tag(n) & S9_ATOM_TAG) && car(n) == S9_T_REAL) #define s9_char_p(n) \ (!s9_special_p(n) && (tag(n) & S9_ATOM_TAG) && car(n) == S9_T_CHAR) #define s9_syntax_p(n) \ (!s9_special_p(n) && (tag(n) & S9_ATOM_TAG) && car(n) == S9_T_SYNTAX) #define s9_input_port_p(n) \ (!s9_special_p(n) && (tag(n) & S9_ATOM_TAG) && \ (tag(n) & S9_PORT_TAG) && car(n) == S9_T_INPUT_PORT) #define s9_output_port_p(n) \ (!s9_special_p(n) && (tag(n) & S9_ATOM_TAG) && \ (tag(n) & S9_PORT_TAG) && car(n) == S9_T_OUTPUT_PORT) #define s9_symbol_p(n) \ (!s9_special_p(n) && (tag(n) & S9_VECTOR_TAG) && car(n) == S9_T_SYMBOL) #define s9_vector_p(n) \ (!s9_special_p(n) && (tag(n) & S9_VECTOR_TAG) && car(n) == S9_T_VECTOR) #define s9_string_p(n) \ (!s9_special_p(n) && (tag(n) & S9_VECTOR_TAG) && car(n) == S9_T_STRING) #define s9_atom_p(n) \ (s9_special_p(n) || (tag(n) & S9_ATOM_TAG) || (tag(n) & S9_VECTOR_TAG)) #define s9_pair_p(x) (!s9_atom_p(x)) #define s9_type_tag(n) \ (S9_TRUE == (n)? S9_T_BOOLEAN: \ S9_FALSE == (n)? S9_T_BOOLEAN: \ (!s9_special_p(n) && (tag(n) & (S9_ATOM_TAG|S9_VECTOR_TAG))? car(n): \ S9_T_NONE)) /* * Allocators */ #define s9_cons(pa, pd) s9_cons3((pa), (pd), 0) #define s9_new_atom(pa, pd) s9_cons3((pa), (pd), S9_ATOM_TAG) #define s9_save(n) (Stack = s9_cons((n), Stack)) /* * Bignum arithmetics */ #define s9_bignum_negative_p(a) ((cadr(a)) < 0) #define s9_bignum_zero_p(a) ((cadr(a)) == 0) #define s9_bignum_positive_p(a) ((cadr(a)) > 0) /* * Real number structure */ #define S9_real_flags(x) (cadr(x)) #define S9_real_exponent(x) (caddr(x)) #define S9_real_mantissa(x) (cdddr(x)) #define S9_REAL_NEGATIVE 0x01 #define S9_real_negative_flag(x) (S9_real_flags(x) & S9_REAL_NEGATIVE) /* * Real-number arithmetics */ #define S9_real_zero_p(x) \ (car(S9_real_mantissa(x)) == 0 && cdr(S9_real_mantissa(x)) == S9_NIL) #define S9_real_negative_p(x) \ (S9_real_negative_flag(x) && !S9_real_zero_p(x)) #define S9_real_positive_p(x) \ (!S9_real_negative_flag(x) && !S9_real_zero_p(x)) #define S9_real_negate(a) \ S9_make_quick_real(S9_real_flags(a) & S9_REAL_NEGATIVE? \ S9_real_flags(a) & ~S9_REAL_NEGATIVE: \ S9_real_flags(a) | S9_REAL_NEGATIVE, \ S9_real_exponent(a), S9_real_mantissa(a)) /* * Globals */ extern s9_cell *S9_car, *S9_cdr; extern char *S9_tag; extern s9_cell *S9_vectors; extern s9_cell S9_stack; extern S9_PRIM *S9_primitives; extern s9_cell S9_zero, S9_one, S9_two, S9_ten; extern s9_cell S9_epsilon; extern FILE *S9_ports[]; extern int S9_input_port, S9_output_port, S9_error_port; extern int S9_error; /* * Prototypes */ void s9_add_image_vars(s9_cell **v); s9_cell s9_apply_prim(s9_cell f, s9_cell a); s9_cell s9_argv_to_list(char **argv); long s9_asctol(char *s); s9_cell s9_bignum_abs(s9_cell a); s9_cell s9_bignum_add(s9_cell a, s9_cell b); s9_cell s9_bignum_divide(s9_cell a, s9_cell b); int s9_bignum_equal_p(s9_cell a, s9_cell b); int s9_bignum_even_p(s9_cell a); int s9_bignum_less_p(s9_cell a, s9_cell b); s9_cell s9_bignum_multiply(s9_cell a, s9_cell b); s9_cell s9_bignum_negate(s9_cell a); s9_cell s9_bignum_shift_left(s9_cell a, int fill); s9_cell s9_bignum_shift_right(s9_cell a); s9_cell s9_bignum_subtract(s9_cell a, s9_cell b); s9_cell s9_bignum_to_int(s9_cell x); s9_cell s9_bignum_to_real(s9_cell a); s9_cell s9_bignum_to_string(s9_cell x); int s9_blockread(char *s, int k); void s9_blockwrite(char *s, int k); void s9_close_port(int port); void s9_close_input_string(void); s9_cell s9_cons3(s9_cell pcar, s9_cell pcdr, int ptag); void s9_cons_stats(int x); s9_cell s9_copy_string(s9_cell x); void s9_count(s9_counter *c); char *s9_dump_image(char *path, char *magic); void s9_exponent_chars(char *s); void s9_fatal(char *msg); s9_cell s9_find_symbol(char *s); s9_cell s9_flat_copy(s9_cell n, s9_cell *lastp); void s9_flush(void); int s9_gc(void); int s9_gcv(void); void s9_gc_verbosity(int n); void s9_get_counters(s9_counter **nc, s9_counter **cc, s9_counter **gc); void s9_mem_error_handler(void (*h)(int src)); void s9_image_vars(s9_cell **v); int s9_input_port(void); int s9_integer_string_p(char *s); s9_cell s9_intern_symbol(s9_cell y); int s9_io_status(void); void s9_io_reset(void); int s9_length(s9_cell n); char *s9_load_image(char *path, char *magic); int s9_lock_port(int port); s9_cell s9_make_char(int c); s9_cell s9_make_integer(s9_cell i); s9_cell s9_make_norm_real(int flags, s9_cell exp, s9_cell mant); s9_cell s9_make_port(int portno, s9_cell type); s9_cell s9_make_primitive(S9_PRIM *p); s9_cell S9_make_real(int flags, s9_cell exp, s9_cell mant); s9_cell s9_make_real(int sign, s9_cell exp, s9_cell mant); s9_cell s9_make_string(char *s, int k); s9_cell s9_make_symbol(char *s, int k); s9_cell s9_make_vector(int k); int s9_new_port(void); s9_cell s9_new_vec(s9_cell type, int size); int s9_open_input_port(char *path); char *s9_open_input_string(char *s); int s9_open_output_port(char *path, int append); int s9_output_port(void); int s9_port_eof(int p); void s9_prints(char *s); int s9_printer_limit(void); void s9_print_bignum(s9_cell n); void s9_print_expanded_real(s9_cell n); void s9_print_real(s9_cell n); void s9_print_sci_real(s9_cell n); int s9_readc(void); s9_cell s9_read_counter(s9_counter *c); s9_cell s9_real_abs(s9_cell a); s9_cell s9_real_add(s9_cell a, s9_cell b); s9_cell s9_real_ceil(s9_cell x); s9_cell s9_real_divide(s9_cell a, s9_cell b); int s9_real_equal_p(s9_cell a, s9_cell b); s9_cell s9_real_exponent(s9_cell x); s9_cell s9_real_floor(s9_cell x); s9_cell s9_real_integer_p(s9_cell x); int s9_real_less_p(s9_cell a, s9_cell b); s9_cell s9_real_mantissa(s9_cell x); s9_cell s9_real_multiply(s9_cell a, s9_cell b); s9_cell s9_real_negate(s9_cell a); s9_cell s9_real_negative_p(s9_cell a); s9_cell s9_real_positive_p(s9_cell a); s9_cell s9_real_power(s9_cell x, s9_cell y); s9_cell s9_real_sqrt(s9_cell x); s9_cell s9_real_subtract(s9_cell a, s9_cell b); s9_cell s9_real_to_bignum(s9_cell r); s9_cell s9_real_to_string(s9_cell r, int mode); s9_cell s9_real_trunc(s9_cell x); s9_cell s9_real_zero_p(s9_cell a); void s9_rejectc(int c); void s9_reset_counter(s9_counter *c); void s9_reset_std_ports(void); void s9_run_stats(int x); void s9_fini(void); void s9_init(s9_cell **extroots); s9_cell s9_set_input_port(s9_cell port); void s9_set_node_limit(int k); s9_cell s9_set_output_port(s9_cell port); void s9_set_printer_limit(int k); void s9_set_vector_limit(int k); int s9_string_numeric_p(char *s); s9_cell s9_string_to_bignum(char *s); s9_cell s9_string_to_number(char *s); s9_cell s9_string_to_real(char *s); s9_cell s9_string_to_symbol(s9_cell x); s9_cell s9_symbol_ref(char *s); s9_cell s9_symbol_table(void); s9_cell s9_symbol_to_string(s9_cell x); char *s9_typecheck(s9_cell f, s9_cell a); int s9_unlock_port(int port); s9_cell s9_unsave(int k); s9/s9.1.txt000644 001751 001751 00000045017 12751175206 012271 0ustar00nmhnmh000000 000000 S9(1) Scheme 9 from Empty Space S9(1) NAME s9 - Scheme Interpreter USAGE s9 [-hv?] [-i name|-] [-gqu] [-d image] [-e expr] [-k size[m]] [-l prog] [-n size[m]] [-r expr] [-f prog [args]] [-- [args]] [prog [args]] DESCRIPTION Scheme 9 from Empty Space is an interpreter for R4RS Scheme with some additional procedures for accessing typical Unix system calls and Unix and Curses library functions (if compiled-in). The s9 command starts the interpreter. OPTIONS -h, -v, or -? Display a brief summary of options. -i name | - Load alternative image file `name.image'. When no image file can be found, try to load `name.scm'. The file will be searched in the entire S9FES_LIBRARY_PATH (see below). When this option is used, it must be the first one of the s9 command. When `-' is specified as name, no heap image will be loaded, and the core library will be read from the source file `s9.scm'. -d file Dump heap image to file and exit. -e expr Read expression from argument, evaluate, and print value. Multiple -e options may be given, which will evaluate from left to right. Interactive mode will not be entered. -f program [argument ...] Run program and exit (implies -q). When there are any arguments, they are passed to the program, where they can be extracted from the *arguments* variable. This option must be the last one. The -f flag is optional. -g[g] Print GC summaries. A single `g' will report pool growth, a second `g' will also include data about pool usage after each collection. -k N[m] Set vector limit to N kilo (or mega) nodes (-k 0 means no limit; use with care!). -l program Load program before entering the REPL or processing -f (may be repeated). -n N[m] Set node limit to N kilo (or mega) nodes (-n 0 means no limit; use with care!). -q Be quiet: skip banners and prompts, exit on errors. -r expr Like -e, but no value will print. Used to run expressions for effect. -u S9 Interpreter Page 1 S9(1) S9(1) Scheme 9 from Empty Space S9(1) Short for -k 0 -n 0 (use unlimited memory). -- [argument ...] Arguments following -- are not interpreted by S9fES, but bound to the *arguments* variable instead. This option must be the last one. ONLINE HELP When the interpreter is running and the default heap image is loaded, just type (help) or ,h to invoke the online help system. When the online help system is not loaded, you will have to run the following command first: (load-from-library "help.scm") META COMMANDS In order to facilitate the invocation of frequently-used top-level procedures, s9 provides the following "meta commands" (they work only when entered directly at the s9 prompt): ,a text = (apropos "text") ,h text = (help "text") ,l file = (load-from-library "file") ,q = (sys:exit) The arguments of ,a and ,h are optional. ADDITIONS S9fES supports nestable block comments of the form #| comment ... |#. Square brackets may be used in the places of parentheses: (cond [(foo) (bar)]). The same type of bracket must be used on both ends of a list. These S9fES procedures are not in R4RS: (argv integer) ==> string | #f Retrieve the value of the given command line argument. Return #f, if there are less than integer+1 arguments. Arguments start at 0. (bit-op integer1 integer2 integer3 ...) ==> integer | #f Implement a variety of bitwise operations. See the bit- op help page for details. (delete-file string) ==> unspecific Delete the file specified in the string argument. If the file does not exist or cannot be deleted, report an error. (environ string) ==> string | #f Retrieve the value of the given environment variable. Return #f, if the variable is undefined. S9 Interpreter Page 2 S9(1) S9(1) Scheme 9 from Empty Space S9(1) (error string) ==> undefined (error string object) ==> undefined Print an error message of the form error: string: object and terminate program execution. (eval object1) ==> object (eval object1 object2) ==> object Evaluate object1 in the current environment and return its normal form. If object2 is also specified, it is ignored. (exponent real) ==> integer Extract the exponent part from a real number. (file-exists? string) ==> boolean Return #t if the file specified in the string argument exists and otherwise #f. (fold-left proc base list ...) ==> object Combine the elements of the lists using proc. Combine elements left-associatively. Base is the leftmost element. (fold-right proc base list ...) ==> object Combine the elements of the lists using proc. Combine elements right-associatively. Base is the rightmost element. (gensym) ==> symbol (gensym symbol) ==> symbol (gensym string) ==> symbol Return a fresh symbol. When a string or symbol argument is given, use it as prefix for the fresh symbol. (load-from-library string) ==> unspecific Attempt to load the file string from each directory of S9FES_LIBRARY_PATH. (locate-file string) ==> string | #f Search for the file string in each directory of S9FES_LIBRARY_PATH in sequence. When the file can be located, return its full path, else return #f. (macro-expand object) ==> object (macro-expand-1 object) ==> object If object is a list resembling a macro application, return the expanded form, else return the object. Macro-expand-1 expands macros only once while macro- expand expands them recursively. (mantissa real) ==> integer Extract the mantissa part from a real number. (print object ...) ==> unspecific Write multiple objects separated by spaces. S9 Interpreter Page 3 S9(1) S9(1) Scheme 9 from Empty Space S9(1) (require-extension ext ...) ==> unspecific Require the named extensions to be compiled-in. Signal an error if not all of the required extensions are present. Ext may be of the form (or ext1 ext2 ...). In this case, it is sufficient if at least one of the given exts is present. (reverse! list) ==> list Reverse list destructively and return the reverse list. (set-input-port! input-port) ==> unspecific Destructively set the current input port. (set-output-port! output-port) ==> unspecific Destructively set the current output port. (stats form) ==> form Evaluate the given form and return a list containing its normal form plus a summary of the resources used to compute that normal form: - reduction steps - conses allocated - total nodes allocated - garbage collections Each resource count will be returned as a group of integers representing ones, thousands, millions, etc. Note that form must be quoted or it will be evaluated before passing it to stats. (symbols) ==> list Return a list of all defined symbols. (system string) ==> number Run the given shell command and return its exit code. (vector-append vector ...) ==> vector Return a fresh vector containing the concatenation of the given vectors. (vector-copy vector) ==> vector (vector-copy vector integer) ==> vector (vector-copy vector integer1 integer2) ==> vector (vector-copy vector integer1 integer2 object) ==> vector Return a copy of the given vector. When integer1 is specified, skip the given number of elements. When integer2 is also specified, copy elements from integer1 up to, but not including, integer2. When integer2 exceeds the size of the original vector, add unspecific slots to the copy. When an object argument is given, fill extra slots with that argument. (void) ==> unspecific Return an unspecific value. Refer to the help pages for descriptions of the Scheme 9 S9 Interpreter Page 4 S9(1) S9(1) Scheme 9 from Empty Space S9(1) extension procedures. SPECIAL VARIABLES These variables are predefined in the dynamic top-level scope of the interpreter. ** (form) The normal form of the expression most recently evaluated at the top level. *arguments* (list of strings) A list of command line arguments passed to the Scheme program (not to the interpreter), i.e. the args in s9 -f file args. *extensions* (list of symbols) Compiled-in extensions. *host-system* (symbol) The host system running the s9 interpreter: unix, plan9, or #F (unknown). *library-path* (string) A verbatim copy of the S9FES_LIBRARY_PATH environment variable (see below). *loading* (boolean) Set to #t when loading a file, else #f. MACROS A macro is a procedure that is applied to its unevaluated arguments. The macro application is replaced with the value returned by the procedure. This happens before the expression containing the macro application is evaluated, so a macro rewrites its own application: (define-syntax (when p . c) `(if ,p (begin ,@c))) (macro-expand '(when (= 1 1) (display "true") (newline) #t)) ==> (if (= 1 1) (begin (display "true") (newline) #t)) (when (= 1 1) 1 2 3) ==> 3 The define-syntax form introduces a new macro: (define-syntax name procedure) ==> unspecific (define-syntax (name args ...) body) ==> unspecific Both of these forms introduce the keyword name and bind it to a procedure. The first form requires the second argument to be a procedure. Like in define forms the second variant implies a procedure definition. Macros may contain applications of macros that were defined earlier. Macros may not recurse directly, but they may implement recursion internally using letrec or by rewriting their own applications. The following macro, for example, does not work, because d is undefined in the body of d: (define-syntax (d x) (and (pair? x) (d (cdr x)))) ; wrong S9 Interpreter Page 5 S9(1) S9(1) Scheme 9 from Empty Space S9(1) The following version does work, though: (define-syntax (d x) (and (pair? x) `(d ,(cdr x)))) ; OK The body of define-syntax may be a syntax-rules transformer, as described in R4RS, if the syntax-rules extension has been loaded. TECHNICAL DETAILS S9fES is a tree-walking interpreter using deep binding and hashed environments. It employs an extremely reliable[1] constant-space mark and sweep garbage collector with in-situ string and vector pool compaction. Memory pools grow on demand. The interpreter uses arbitrary-precision integer arithmetics and decimal-based real number arithmetics. INTERPRETER START-UP When the s9 interpreter is started, the following steps will be performed in this order: Load library. The interpreter searches its library path (either built- in or specified in the S9FES_LIBRARY_PATH environment variable) for a heap image file or the library source code. The heap image file is the name of the interpreter with a .image suffix appended. An alternative name can be specified with the -i option (see OPTIONS). The default library source code is named s9.scm. First all directories of the library path are searched for images, then the directories are searched for library sources. Initialize extensions. Any extensions compiled into the interpreter are initialized by calling the nullary procedure ext:ext (where ext is the name of the extension). The procedures are optional. The last `extension' being initialized is S9 itself, so when a procedure named s9:s9 exists, it will be called at this point. Evaluate command line options. When a -l file option is found, the program contained in the given file will be loaded. When a -f file args option is found, the program contained in the file will be run and then S9 will exit. Args will be passed to the program. Enter REPL. Interactive mode is only entered, when no -e, -f, or -r option was given and no program was specified. ALLOCATION STRATEGY The S9fES memory pools grow exponentially until the memory limit is reached. When the limit is reached, the current computation is aborted. A memory limit can be specified using the -k, -n, and -u command line options. The limit is specified in units of 1024 nodes/cells (or in units of 1024*1024 nodes/cells by appending an m suffix). S9 Interpreter Page 6 S9(1) S9(1) Scheme 9 from Empty Space S9(1) Note that computations may abort before the limit is reached due to the way the pool grows. Use the -g command line option to experiment with pool sizes. Specifying a limit of zero (or using the -u option) disables the memory limit completely and the interpreter will allocate as much memory as it can get. This option should be used with care. LIMITATIONS These parts of R4RS are not implemented: I/O: char-ready? (this is in the sys-unix extension). Transcripts: transcript-off, transcript-on. Rational and complex numbers and related procedures. The atan procedure does not accept a second argument. BUGS You may not quasiquote quasiquote unless in unquote (e.g.: ``x does not work, but `,`x does). The macro expander will expand (x) in (cond (x)), if x is a macro. Syntax-rules is not fully hygienic. Call/cc must be the only argument when used in lambda (or derived binding syntax, such as let). Not observing this rule will break the interpreter. FILES @S9DIR@ The S9fES procedure library (source code). @S9DIR@/s9.image The interpreter heap image. *.scm Scheme source code. ENVIRONMENT S9FES_LIBRARY_PATH A colon-separated list of directories which will be searched for the s9 library when the interpreter is launched. The same directories will be searched by the locate-file procedure. Default: .:~/.s9fes:@S9DIR@ SIGNALS SIGINT Abort input or terminate program execution. SIGQUIT Terminate the interpreter process (emergency exit). SIGTERM Silently terminate the interpreter process. "interrupt" On Plan 9, receiving an interrupt note will abort input or terminate program execution, as SIGINT would on Unix. FOOTNOTES [1] See comp.lang.scheme Usenet message (Thu, 27 Aug 2009 13:27:42 -0400) and its follow-ups. S9 Interpreter Page 7 S9(1) S9(1) Scheme 9 from Empty Space S9(1) REFERENCES The Revised^4 Report on the Algorithmic Language Scheme. http://www-swiss.ai.mit.edu/~jaffer/r4rs_toc.html Scheme 9 from Empty Space -- A Guide to Implementing Scheme in C. Available at Lulu.com, see http://www.t3x.org AUTHOR Nils M Holm S9 Interpreter Page 8 S9(1) s9/LICENSE000644 001751 001751 00000002127 12477646543 012052 0ustar00nmhnmh000000 000000 Scheme 9 from Empty Space A Portable Scheme Interpreter with a Unix Interface By Nils M Holm, 2007-2015 This code is free. FREE! What's so hard to understand about this? It is in public domain. Neither mine nor yours. Do whatever you want with it! The following section in short means: "If this code should break something, don't blame me." Just in case. Disclaimer: THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. s9/contrib/000755 001751 001751 00000000000 12622454661 012471 5ustar00nmhnmh000000 000000 s9/lib/000755 001751 001751 00000000000 12622454661 011577 5ustar00nmhnmh000000 000000 s9/ext/000755 001751 001751 00000000000 13041740620 011616 5ustar00nmhnmh000000 000000 s9/help/000755 001751 001751 00000000000 13042075333 011751 5ustar00nmhnmh000000 000000 s9/prog/000755 001751 001751 00000000000 13042354133 011766 5ustar00nmhnmh000000 000000 s9/util/000755 001751 001751 00000000000 12622626147 012006 5ustar00nmhnmh000000 000000 s9/README000644 001751 001751 00000016436 13021527520 011710 0ustar00nmhnmh000000 000000 Scheme 9 from Empty Space A Portable Scheme Interpreter with a Unix Interface By Nils M Holm, 2007-2016 S9fES is a mature, portable, and comprehensible public-domain interpreter for R4RS Scheme offering - bignum arithmetics - decimal-based real number arithmetics - support for low-level Unix programming - cursor addressing with Curses - basic networking procedures - loads of useful library functions It is written in ANSI C (C89) and Scheme and it runs in many popular environments, including *BSD, Linux, Plan 9, and the unmentionable horror (although the Plan 9 and Horror versions will exclude the Unix, Curses, and Networking extensions). The S9fES code strives to be simple and comprehensible. It is particularly interesting to people who want to - have a Scheme system that runs virtually everywhere - write Unix programs in a high-level language - try Scheme without having to jump through too many hoops - study the implementation of Scheme (in a language other than Scheme) There is a book describing the S9 implementation in detail. It is available in print and PDF format. See http://t3x.org/s9book/ S9fES supports the following SRFI's: - SRFI-0: feature-based conditional expansion (subset) - SRFI-2: AND-LET* (subset) - SRFI-22: running Scheme scripts on Unix - SRFI-23: error reporting mechanism - SRFI-30: nested multi-line comments - SRFI-43: vector library (subset) QUICK START You can run the interpreter in its build directory without installing it. Just type "cc -Dunix -o s9 s9.c" (or -Dplan9) and then "./s9". The S9 code is only loosely coupled to its Makefile, so in most cases running "cc -Dunix -o s9 s9.c" or "8c -Dplan9 -o s9 s9.c" will compile the interpreter just fine. (However, doing so will not include the Unix/Curses/Networking extensions.) On most systems of the Unix family (plus CygWin and MinGW), you can compile and install S9fES by running "make install". Once installed, typing "s9" will start the interpreter. ,h explains the online help system. ,a returns a list of all help topics (long!). If the above commands do not work, try ,l contrib/help.scm first. COMPILING AND INSTALLING Unix To compile S9fES, run "make" and then "make test" (this will run the test suite to make sure that the interpreter works properly). Running "make tests" will run even more tests. On 64-bit systems, you may have to add the -DBITS_PER_WORD_64 define to the Makefile. Not doing so will probably still work, but may result in slightly worse bignum performance. You can install S9fES (including the goodies) on a Unix system by typing "make install" as root, but before doing so, please edit at least the PREFIX variable at the beginning of Makefile. (Be sure to re-compile S9fES (make clean; make) after changing PREFIX, because it is used to set up some internal paths). Plan 9 Before installing, run "rc util/fix-help-files". The help/ directory contains symlinks, and the above script replaces them by copies. To compile S9fES on Plan 9 from Bell Labs, just type "mk". The "test" and "tests" targets will run tests, just like on Unix. To install S9fES, run "mk inst". It will copy the S9fES binary, heap image, function library, and help files to $s9dir (which defaults to /lib/s9fes). Edit mkfile if you prefer a different location. The install procedure will also copy the file util/s9.rc to /rc/bin/s9 and adjust the $s9dir variable in that file. Manual Installation To install S9fES manually, - Compile s9 with a proper library path (the one hardwired in "s9.h" is probably not what you want). E.g.: cc -o s9 -DLIBRARY_PATH="\"your-path\"" s9.c A reasonable value for "your-path" would be, for example: ".:~/s9fes:/usr/local/share/s9fes" Security-sensitive people may consider (re)moving the dot. - Copy the "s9" binary to a location where it can be executed (e.g. /usr/local/bin). - Copy the file "s9.scm" to a publicly readable directory (default: /usr/local/share/s9fes). This directory will be referred to as S9DIR in the following instructions. Note that this directory *must* be contained in LIBRARY_PATH, as defined above. - Compile a heap image and copy it to S9DIR: s9 -i - -d s9.image The image file must have the same base name as the interpreter or it will not be loaded. An image loads significantly faster than source code. Optionally: - Copy the content of the "lib" directory to S9DIR. This directory contains lots of useful Scheme functions. - Copy the content of the "contrib" directory to S9DIR. These files contain additional Scheme functions contributed by other authors and/or imported from various sources. - Create a subdirectory named "help" in S9DIR and copy the content of the "help" directory to S9DIR/help. These files are part of the interactive help system. - Copy the nroff(1) source code of the manual page "s9.1" to section 1 of your online manual (e.g. /usr/local/man/man1). In case you are not running Unix, there is a pre-formatted copy in the file "s9.1.txt". CONFIGURATION You may create the S9FES_LIBRARY_PATH environment variable and make it point to S9DIR as well as other directories that contain Scheme programs. The variable may contain a single directory or a colon-separated list of directories that will be searched in sequence for image files, library files, and help pages (in "help" subdirectories contained in the given paths). S9FES_LIBRARY_PATH overrides LIBRARY_PATH, so all directories listed in the latter should also be present in the former. To create an image file containing additional functionality, add the desired options to the "config.scm" file and run s9 -i - -l config.scm -d s9.image (This step is already included in the default Unix Makefile and Plan 9 mkfile). GETTING STARTED Typing "s9" will drop you into the read-eval-print loop of the interpreter. You can run Scheme programs non-interactively by typing "s9 -f program.scm" (or just "s9 program.scm") at your shell prompt. If you installed the extension library functions in S9DIR, they can be loaded by the LOAD-FROM-LIBRARY procedure or the ",l" (comma ell) meta command: > ,l draw-tree ; loading from /usr/local/share/s9fes/draw-tree.scm > (draw-tree '(a b c)) [o|o]---[o|o]---[o|/] | | | a b c > _ Feel free to explore them. Running "s9help topic" on the shell prompt will print the S9fES online help page about the given topic. EXTENDED INTERPRETER If compiled in, there are some extension procedures providing access to some Unix system calls, some networking procedures, and a Curses interface. To compile these extensions, uncomment the corresponding EXTRA_ lines in the Makefile. (In fact, all extensions are compiled in by default on Unix.) ACKNOWLEDGEMENTS I would like to thank the following people and organisations for patches, bug reports, suggestions, hardware, access to hardware, etc: Alexander Shendi, Arun Srinivasan, Bakul Shah, Barak Pearlmutter, Blake McBride, Bsamograd (reddit), David Person, Dig1 (reddit), Dirk Lutzebaeck, Doug Currie, Mario Deilmann, Masaru KIMURA, Nullbuilt0 (reddit), Ray Lai, Torsten Leibold, Yi Dai, and the Super Dimension Fortress (SDF.ORG). CONTACT Nils M Holm < n m h @ t 3 x . o r g > s9/Makefile000644 001751 001751 00000017127 13201115261 012461 0ustar00nmhnmh000000 000000 # Scheme 9 from Empty Space # Makefile (obviously) # By Nils M Holm, 2007-2017 # In the public domain # Change at least this line: PREFIX= /u # Base version and Release BASE= 20170124 RELEASE= 20171109 # Override default compiler and flags # CC= cc CFLAGS= -g -Wall -std=c99 -pedantic -O2 # Which OS are we using (unix or plan9)? OSDEF= -Dunix # Uncomment these to include the Unix extensions EXTRA_SCM+= -l ext/sys-unix/unix.scm -l ext/sys-unix/unix-tools.scm EXTRA_OBJS+= unix.o EXTRA_INIT+= sys_init(); EXTRA_LIBS+= # Uncomment these to include the Curses extensions EXTRA_SCM+= -l ext/curses/curses.scm EXTRA_OBJS+= curses.o EXTRA_INIT+= curs_init(); EXTRA_LIBS+= -lncurses # Uncomment these to include the CSV extensions EXTRA_SCM+= -l ext/csv/csv.scm EXTRA_OBJS+= csv.o EXTRA_INIT+= csv_init(); EXTRA_LIBS+= # Options to be added to $(DEFS) # -DBITS_PER_WORD_64 # use 64-bit bignum arithmetics # -DLIBRARY_PATH="\"dir:...\"" # # search path for LOCATE-FILE, etc # -DNETWORK # include socket code in the Unix extension # -DCURSES_COLOR # enable the CURS:SET-COLOR primitive # -DCURSES_RESET # automatically run CURS:ENDWIN on the REPL # # (requires the Curses extension) DEFS= $(OSDEF) \ -DLIBRARY_PATH="\".:~/s9fes:$(S9DIR)\"" \ -DEXTENSIONS="$(EXTRA_INIT)" \ -DNETWORK \ -DCURSES_COLOR \ -DCURSES_RESET # Where to install the stuff S9DIR= $(PREFIX)/share/s9fes BINDIR= $(PREFIX)/bin INCDIR= $(PREFIX)/include LIBDIR= $(PREFIX)/lib MANDIR= $(PREFIX)/man/man1 # Set up environment to be used during the build process BUILD_ENV= env S9FES_LIBRARY_PATH=.:lib:ext/sys-unix:ext/curses:ext/csv:contrib SETPREFIX= sed -e "s|^\#! /usr/local|\#! $(PREFIX)|" default: s9 s9.image s9.1.gz s9.1.txt libs9core.a all: default s9: s9.o s9core.o $(EXTRA_OBJS) $(CC) -o s9 $(LDFLAGS) s9.o s9core.o $(EXTRA_OBJS) $(EXTRA_LIBS) s9.o: s9.c s9core.h s9import.h s9ext.h $(CC) -o s9.o $(CFLAGS) $(DEFS) -c s9.c s9core.o: s9core.c s9core.h $(CC) -o s9core.o $(CFLAGS) $(DEFS) -c s9core.c s9.image: s9 s9.scm ext/sys-unix/unix.scm ext/curses/curses.scm \ ext/csv/csv.scm config.scm $(BUILD_ENV) ./s9 -i - $(EXTRA_SCM) -l config.scm -d s9.image libs9core.a: s9core.o ar q libs9core.a s9core.o s9.1.gz: s9.1 sed -e "s,@S9DIR@,$(S9DIR)," s9.1.gz unix.o: ext/sys-unix/unix.c s9core.h s9import.h s9ext.h $(CC) $(CFLAGS) $(DEFS) -I . -o unix.o -c ext/sys-unix/unix.c curses.o: ext/curses/curses.c s9core.h s9import.h s9ext.h $(CC) $(CFLAGS) $(DEFS) -I . -o curses.o -c ext/curses/curses.c csv.o: ext/csv/csv.c s9core.h s9import.h s9ext.h $(CC) $(CFLAGS) $(DEFS) -I . -o csv.o -c ext/csv/csv.c lint: cc -g -Wall -ansi -pedantic -O3 s9.c s9core.c && rm a.out test: s9 test.image $(BUILD_ENV) ./s9 -i test -f util/test.scm libtest: s9 test.image $(BUILD_ENV) sh util/libtest.sh systest: s9 test.image s9.image $(BUILD_ENV) ./s9 -i test -f util/systest.scm srtest: s9 test.image $(BUILD_ENV) ./s9 -i test -f util/srtest.scm realtest: s9 test.image $(BUILD_ENV) ./s9 -i test -f util/realtest.scm test.image: s9 s9.scm $(BUILD_ENV) ./s9 -i - $(EXTRA_SCM) -d test.image tests: test realtest srtest libtest systest install: install-s9 install-util install-all: install-s9 install-util install-progs # old version of install(1) may need -c #C=-c install-s9: s9 s9.scm s9.image s9.1.gz install -d -m 0755 $(S9DIR) install -d -m 0755 $(S9DIR)/help install -d -m 0755 $(S9DIR)/help/sys-unix install -d -m 0755 $(S9DIR)/help/curses install -d -m 0755 $(S9DIR)/help/csv install -d -m 0755 $(BINDIR) install -d -m 0755 $(LIBDIR) install -d -m 0755 $(INCDIR) install -d -m 0755 $(MANDIR) install $C -m 0755 s9 $(BINDIR) strip $(BINDIR)/s9 install $C -m 0644 s9.scm $(S9DIR) install $C -m 0644 s9.image $(S9DIR) install $C -m 0644 lib/* $(S9DIR) install $C -m 0644 ext/sys-unix/*.scm $(S9DIR) install $C -m 0644 ext/curses/*.scm $(S9DIR) install $C -m 0644 ext/csv/*.scm $(S9DIR) install $C -m 0644 contrib/* $(S9DIR) install $C -m 0644 s9.1.gz $(MANDIR) (tar cf - help | tar xfC - $(S9DIR)) install $C -m 0644 libs9core.a $(LIBDIR) install $C -m 0644 s9core.h $(INCDIR) install $C -m 0644 s9import.h $(INCDIR) install $C -m 0755 util/make-help-links $(S9DIR) install-util: $(SETPREFIX) $(BINDIR)/s9help $(SETPREFIX) $(BINDIR)/s9resolve $(SETPREFIX) $(BINDIR)/scm2html $(SETPREFIX) $(BINDIR)/scmpp -chmod +x $(BINDIR)/s9help \ $(BINDIR)/s9resolve \ $(BINDIR)/scm2html \ $(BINDIR)/scmpp install-progs: $(SETPREFIX) $(BINDIR)/advgen $(SETPREFIX) $(BINDIR)/c2html $(SETPREFIX) $(BINDIR)/cols $(SETPREFIX) $(BINDIR)/dupes $(SETPREFIX) $(BINDIR)/edoc $(SETPREFIX) $(BINDIR)/htmlify $(SETPREFIX) $(BINDIR)/s9hts $(SETPREFIX) $(BINDIR)/soccat -chmod +x $(BINDIR)/advgen \ $(BINDIR)/c2html \ $(BINDIR)/cols \ $(BINDIR)/dupes \ $(BINDIR)/edoc \ $(BINDIR)/htmlify \ $(BINDIR)/s9hts \ $(BINDIR)/soccat deinstall: deinstall-s9 deinstall-util deinstall-progs deinstall-s9: rm -f $(S9DIR)/help/* && rmdir $(S9DIR)/help rm -f $(S9DIR)/* && rmdir $(S9DIR) rm -f $(BINDIR)/s9 -rmdir $(BINDIR) -rmdir $(MANDIR) deinstall-util: rm -f $(BINDIR)/s9help \ $(BINDIR)/s9resolve \ $(BINDIR)/scm2html \ $(BINDIR)/scmpp deinstall-progs: rm -f $(BINDIR)/advgen \ $(BINDIR)/c2html \ $(BINDIR)/cols \ $(BINDIR)/dupes \ $(BINDIR)/edoc \ $(BINDIR)/htmlify \ $(BINDIR)/s9hts \ $(BINDIR)/soccat tabs: @find . -name \*.scm -exec grep -l " " {} \; cd: ./s9 -f util/check-descr.scm clean: rm -f s9 s9.image libs9core.a test.image s9.1.gz *.o *.core \ CATEGORIES.html HACKING.html core s9fes-$(RELEASE).tgz \ s9fes-$(BASE).tgz s9core-$(RELEASE).tgz __testfile__ \ _meta _toc.tr _xref.tr _ndx.tr new-version: vi Makefile s9.c CHANGES make s9.c update-library: vi util/make-docs util/make-docs vi util/make-help-links \ util/descriptions \ util/categories.html cd help && s9 -f ../util/procedures.scm >INDEX @echo @echo "Now copy the new help pages from help-new to help" @echo "and run util/make-help-links." s9.1.txt: s9.1 $(CC) -o rpp util/rpp.c nroff -c -mdoc s9.1 | ./rpp -a >s9.1.txt rm -f rpp docs: lib ext/sys-unix ext/sys-plan9 ext/curses ext/csv contrib util/make-docs mv -f help-new/sys-unix/* help/sys-unix # mv -f help-new/sys-plan9/* help/sys-plan9 mv -f help-new/curses/* help/curses # mv -f help-new/csv/* help/csv rm help-new/sys-plan9/* rmdir help-new/sys-unix help-new/sys-plan9 help-new/curses help-new/csv mv -f help-new/* help rmdir help-new webdump: util/make-html -r $(RELEASE) advdump: prog/advgen.scm prog/adventure.adv prog/adventure.intro sed -e 's/@dir/quest/' -e 's/@file/index/g' pagehead prog/advgen.scm -rv \ -P terminal:session \ -p pagehead \ -e util/pagetail \ -i prog/adventure.intro \ -t "The Quest for S9fES" \ -y ../t3x.css \ prog/adventure.adv rm -f pagehead cp MASCOT.png advdump csums: csum -u <_csums >_csums.new mv _csums.new _csums mksums: clean find . -type f | grep -v _csums | csum >_csums dist: clean s9.1.txt make clean cd .. && \ tar cf - s9 | gzip -9 > s9fes-$(RELEASE).tgz && \ mv s9fes-$(RELEASE).tgz s9 ls -l s9fes-$(RELEASE).tgz | awk '{print int($$5/1024+.5)}' cdist: tar cf - s9core.[ch] s9import.h s9core.txt README.s9core \ | gzip -9 > s9core-$(RELEASE).tgz arc: clean s9.1.txt cd .. && tar cf - s9 | gzip -9 > s9fes-$(BASE).tgz && \ mv s9fes-$(BASE).tgz s9 ls -l s9fes-$(BASE).tgz | awk '{print int($$5/1024+.5)}' s9/config.scm000644 001751 001751 00000001160 12506557626 013006 0ustar00nmhnmh000000 000000 ; Configuration file for the S9 default heap image. ; Choose your extras or add your own stuff. (load-from-library "help.scm") (load-from-library "pretty-print.scm") (load-from-library "draw-tree.scm") (load-from-library "hash-table.scm") (load-from-library "keyword-value.scm") (load-from-library "graph-tools.scm") (load-from-library "io-tools.scm") (load-from-library "list-tools.scm") (load-from-library "math-tools.scm") (load-from-library "set-tools.scm") (load-from-library "stat-tools.scm") (load-from-library "string-tools.scm") (load-from-library "syntax-extensions.scm") (load-from-library "vector-tools.scm") s9/configure000755 001751 001751 00000000737 12537021252 012736 0ustar00nmhnmh000000 000000 #!/bin/sh cat </rc/bin/s9 deinst: rm -rf /lib/s9fes rm -f /rc/bin/s9 /$objtype/bin/s9fes string | #f .in +4 Retrieve the value of the given command line argument. Return \fB#f\fP, if there are less than \fIinteger\fP+1 arguments. Arguments start at 0. .in -4 .sp .ne 3 .B "(bit-op integer1 integer2 integer3 ...) ==> integer | #f .in +4 Implement a variety of bitwise operations. See the .B bit-op help page for details. .in -4 .sp .ne 3 .B "(delete-file string) ==> unspecific .in +4 Delete the file specified in the .I string argument. If the file does not exist or cannot be deleted, report an error. .in -4 .sp .ne 3 .B "(environ string) ==> string | #f .in +4 Retrieve the value of the given environment variable. Return \fB#f\fP, if the variable is undefined. .in -4 .sp .ne 3 .B "(error string) ==> undefined .br .B "(error string object) ==> undefined .in +4 Print an error message of the form .I "error: string: object and terminate program execution. .in -4 .sp .ne 3 .B "(eval object1) ==> object .br .B "(eval object1 object2) ==> object .in +4 Evaluate .I object1 in the current environment and return its normal form. If .I object2 is also specified, it is ignored. .in -4 .sp .ne 3 .B "(exponent real) ==> integer .in +4 Extract the exponent part from a real number. .in -4 .sp .ne 3 .B "(file-exists? string) ==> boolean .in +4 Return .B "#t if the file specified in the .I string argument exists and otherwise \fB#f\fP. .in -4 .sp .ne 4 .B "(fold-left proc base list ...) ==> object .in +4 Combine the elements of the .IR list s using .IR proc . Combine elements left-associatively. .I Base is the leftmost element. .in -4 .sp .ne 4 .B "(fold-right proc base list ...) ==> object .in +4 Combine the elements of the .IR list s using .IR proc . Combine elements right-associatively. .I Base is the rightmost element. .in -4 .sp .B "(gensym) ==> symbol .br .B "(gensym symbol) ==> symbol .br .B "(gensym string) ==> symbol .in +4 Return a fresh symbol. When a .I string or .I symbol argument is given, use it as prefix for the fresh symbol. .in -4 .sp .ne 2 .B "(load-from-library string) ==> unspecific .in +4 Attempt to .B load the file .I string from each directory of .IR S9FES_LIBRARY_PATH . .in -4 .sp .ne 2 .B "(locate-file string) ==> string | #f .in +4 Search for the file .I string in each directory of .I S9FES_LIBRARY_PATH in sequence. When the file can be located, return its full path, else return \fB#f\fP. .in -4 .sp .ne 3 .B "(macro-expand object) ==> object .br .B "(macro-expand-1 object) ==> object .in +4 If .I object is a list resembling a macro application, return the expanded form, else return the object. .B Macro-expand-1 expands macros only once while .B macro-expand expands them recursively. .in -4 .sp .ne 3 .B "(mantissa real) ==> integer .in +4 Extract the mantissa part from a real number. .in -4 .sp .ne 2 .B "(print object ...) ==> unspecific .in +4 Write multiple .IR object s separated by spaces. .in -4 .sp .ne 2 .B "(require-extension ext ...) ==> unspecific .in +4 Require the named extensions to be compiled-in. Signal an error if not all of the required extensions are present. .I Ext may be of the form \fI(or ext1 ext2 ...)\fP. In this case, it is sufficient if at least one of the given \fIext\fPs is present. .in -4 .sp .ne 2 .B "(reverse! list) ==> list .in +4 Reverse .I list destructively and return the reverse list. .in -4 .sp .ne 2 .B "(set-input-port! input-port) ==> unspecific .in +4 Destructively set the current input port. .in -4 .sp .ne 2 .B "(set-output-port! output-port) ==> unspecific .in +4 Destructively set the current output port. .in -4 .sp .ne 2 .B "(stats form) ==> form .in +4 Evaluate the given .I form and return a list containing its normal form plus a summary of the resources used to compute that normal form: .sp .in +4 .nf - reduction steps - conses allocated - total nodes allocated - garbage collections .fi .in -4 .sp Each resource count will be returned as a group of integers representing ones, thousands, millions, etc. Note that .I form must be quoted or it will be evaluated before passing it to .BR stats . .in -4 .sp .ne 2 .B "(symbols) ==> list .in +4 Return a list of all defined symbols. .in -4 .sp .ne 3 .B "(system string) ==> number .in +4 Run the given shell command and return its exit code. .in -4 .sp .ne 3 .B "(vector-append vector ...) ==> vector .in +4 Return a fresh vector containing the concatenation of the given vectors. .in -4 .sp .ne 3 .B "(vector-copy vector) ==> vector .br .B "(vector-copy vector integer) ==> vector .br .B "(vector-copy vector integer1 integer2) ==> vector .br .B "(vector-copy vector integer1 integer2 object) ==> vector .in +4 Return a copy of the given vector. When .I integer1 is specified, skip the given number of elements. When .I integer2 is also specified, copy elements from .I integer1 up to, but not including, .IR integer2 . When .I integer2 exceeds the size of the original vector, add unspecific slots to the copy. When an .I object argument is given, fill extra slots with that argument. .in -4 .sp .ne 3 .B "(void) ==> unspecific .in +4 Return an unspecific value. .in -4 .sp Refer to the help pages for descriptions of the Scheme 9 extension procedures. .SH "SPECIAL VARIABLES These variables are predefined in the dynamic top-level scope of the interpreter. .sp .ne 2 .B "** (form) .in +4 The normal form of the expression most recently evaluated at the top level. .in -4 .ne 2 .B "*arguments* (list of strings) .in +4 A list of command line arguments passed to the .I "Scheme program (not to the interpreter), i.e. the .I args in \fIs9 -f file args\fP. .in -4 .ne 2 .B "*extensions* (list of symbols) .in +4 Compiled-in extensions. .in -4 .ne 2 .B "*host-system* (symbol) .in +4 The host system running the \fBs9\fP interpreter: \fBunix\fP, \fBplan9\fP, or .B "#F (unknown). .in -4 .ne 2 .B "*library-path* (string) .in +4 A verbatim copy of the .I S9FES_LIBRARY_PATH environment variable (see below). .in -4 .ne 2 .B "*loading* (boolean) .in +4 Set to .B #t when \fBload\fPing a file, else \fB#f\fP. .in -4 .SH "MACROS A macro is a procedure that is applied to its unevaluated arguments. The macro application is replaced with the value returned by the procedure. This happens before the expression containing the macro application is evaluated, so a macro .I rewrites its own application: .sp .ne 2 .nf (define-syntax (when p . c) `(if ,p (begin ,@c))) (macro-expand '(when (= 1 1) (display "true") (newline) #t)) ==> (if (= 1 1) (begin (display "true") (newline) #t)) (when (= 1 1) 1 2 3) ==> 3 .fi .sp The .B define-syntax form introduces a new macro: .sp .ne 3 .B "(define-syntax name procedure) ==> unspecific .br .B "(define-syntax (name args ...) body) ==> unspecific .sp Both of these forms introduce the keyword .I name and bind it to a procedure. The first form requires the second argument to be a procedure. Like in .B define forms the second variant implies a procedure definition. .sp Macros may contain applications of macros that were defined earlier. Macros may not recurse directly, but they may implement recursion internally using .B letrec or by rewriting their own applications. The following macro, for example, does .I not work, because .I d is undefined in the body of .IR d : .sp .B "(define-syntax (d x) (and (pair? x) (d (cdr x)))) ; wrong" .sp The following version .I does work, though: .sp .B "(define-syntax (d x) (and (pair? x) `(d ,(cdr x)))) ; OK" .sp The body of .B define-syntax may be a .B syntax-rules transformer, as described in R4RS, if the .B syntax-rules extension has been loaded. .SH "TECHNICAL DETAILS S9fES is a tree-walking interpreter using deep binding and hashed environments. It employs an extremely reliable[1] constant-space mark and sweep garbage collector with in-situ string and vector pool compaction. Memory pools grow on demand. The interpreter uses arbitrary-precision integer arithmetics and decimal-based real number arithmetics. .SH "INTERPRETER START-UP When the .B s9 interpreter is started, the following steps will be performed in this order: .sp Load library. .in +4 The interpreter searches its library path (either built-in or specified in the .I S9FES_LIBRARY_PATH environment variable) for a heap image file or the library source code. The heap image file is the name of the interpreter with a .I .image suffix appended. An alternative name can be specified with the .B -i option (see .BR OPTIONS ). The default library source code is named .IR s9.scm . First all directories of the library path are searched for images, then the directories are searched for library sources. .in -4 .sp Initialize extensions. .in +4 Any extensions compiled into the interpreter are initialized by calling the nullary procedure .B ext:ext (where .B ext is the name of the extension). The procedures are optional. The last `extension' being initialized is .B S9 itself, so when a procedure named .B s9:s9 exists, it will be called at this point. .in -4 .sp Evaluate command line options. .in +4 When a .B "-l file option is found, the program contained in the given file will be .BR load ed. When a .B "-f file args option is found, the program contained in the file will be run and then S9 will exit. .B Args will be passed to the program. .in -4 .sp .ne 2 Enter REPL. .in +4 Interactive mode is only entered, when no .BR -e , .BR -f , or .BR -r option was given and no program was specified. .in -4 .SH "ALLOCATION STRATEGY The S9fES memory pools grow exponentially until the memory limit is reached. When the limit is reached, the current computation is aborted. A memory limit can be specified using the \fB-k\fP, \fB-n\fP, and .B -u command line options. The limit is specified in units of 1024 nodes/cells (or in units of 1024*1024 nodes/cells by appending an .B m suffix). .sp Note that computations may abort .I before the limit is reached due to the way the pool grows. Use the .B -g command line option to experiment with pool sizes. .br Specifying a limit of zero (or using the .B -u option) disables the memory limit completely and the interpreter will allocate as much memory as it can get. This option should be used with care. .SH "LIMITATIONS These parts of R4RS are not implemented: .sp I/O: .B char-ready? (this is in the .B sys-unix extension). .br Transcripts: .BR transcript-off , .BR transcript-on . .br Rational and complex numbers and related procedures. .br The .B atan procedure does not accept a second argument. .SH "BUGS You may not quasiquote .B quasiquote unless in .BR unquote (e.g.: .B ``x does not work, but .B `,`x does). .br The macro expander will expand .B (x) in \fB(cond (x))\fP, if .B x is a macro. .br .B Syntax-rules is not fully hygienic. .br .B Call/cc must be the only argument when used in .B lambda (or derived binding syntax, such as .BR let ). Not observing this rule .I will break the interpreter. .SH "FILES .ne 2 .B @S9DIR@ .in +4 The S9fES procedure library (source code). .in -4 .ne 2 .B @S9DIR@/s9.image .in +4 The interpreter heap image. .in -4 .ne 2 .B *.scm .in +4 Scheme source code. .in -4 .SH "ENVIRONMENT .B S9FES_LIBRARY_PATH .in +4 A colon-separated list of directories which will be searched for the s9 library when the interpreter is launched. The same directories will be searched by the .B locate-file procedure. .br Default: .I \&.:~/.s9fes:@S9DIR@ .in -4 .SH "SIGNALS .ne 3 .B "SIGINT .in +4 Abort input or terminate program execution. .in -4 .ne 3 .B "SIGQUIT .in +4 Terminate the interpreter process (emergency exit). .in -4 .B "SIGTERM .in +4 Silently terminate the interpreter process. .in -4 .B """interrupt""" .in +4 On Plan 9, receiving an .I interrupt note will abort input or terminate program execution, as .I SIGINT would on Unix. .in -4 .SH "FOOTNOTES .B [1] See .I comp.lang.scheme Usenet message .in +4 .I " .br (Thu, 27 Aug 2009 13:27:42 -0400) and its follow-ups. .in -4 .SH "REFERENCES .ne 3 The Revised^4 Report on the Algorithmic Language Scheme. .in +4 .B "http://www-swiss.ai.mit.edu/~jaffer/r4rs_toc.html .in -4 .sp .ne 3 Scheme 9 from Empty Space -- A Guide to Implementing Scheme in C. .in +4 .B "Available at Lulu.com, see http://www.t3x.org .in -4 .SH AUTHOR Nils M Holm s9/s9core.c000644 001751 001751 00000202270 13201114026 012362 0ustar00nmhnmh000000 000000 /* * S9core Toolkit, Mk IIIc * By Nils M Holm, 2007-2017 * In the public domain * * Added S9_error * new_vec(T_VECTOR, ...) initializes vector elts with NIL */ #include "s9core.h" #define S9_S9CORE #include "s9import.h" /* * Global state */ static int Cons_segment_size, Vec_segment_size; static int Cons_pool_size, Vec_pool_size; static int Verbose_GC = 0; s9_cell *Car, *Cdr; char *Tag; s9_cell *Vectors; cell Stack; static cell Free_list; static cell Free_vecs; S9_PRIM *Primitives; static int Last_prim, Max_prims; static cell Tmp_car, Tmp_cdr, Tmp; static cell Symbols; static int Printer_count, Printer_limit; static int IO_error; FILE *Ports[S9_MAX_PORTS]; static char Port_flags[S9_MAX_PORTS]; int Input_port, Output_port, Error_port; int Error; static char *Str_outport; static int Str_outport_len; static char *Str_inport; static char Rejected[2]; static long Node_limit, Vector_limit; static char *Exponent_chars; static cell **Image_vars; static void (*Mem_error_handler)(int src); /* Predefined bignum literals */ cell Zero, One, Two, Ten; /* Smallest value by which two real numbers can differ: * 10 ^ -(S9_MANTISSA_SIZE+1) */ cell Epsilon; /* Internal GC roots */ static cell *GC_int_roots[] = { &Stack, &Symbols, &Tmp, &Tmp_car, &Tmp_cdr, &Zero, &One, &Two, &Ten, &Epsilon, NULL }; /* External GC roots */ static cell **GC_ext_roots = NULL; /* * Internal vector representation */ #define RAW_VECTOR_LINK 0 #define RAW_VECTOR_INDEX 1 #define RAW_VECTOR_SIZE 2 #define RAW_VECTOR_DATA 3 /* * Counting */ static int Run_stats, Cons_stats; static s9_counter Conses, Nodes, Collections; void s9_run_stats(int x) { Run_stats = x; if (Run_stats) { s9_reset_counter(&Nodes); s9_reset_counter(&Conses); s9_reset_counter(&Collections); } } void s9_cons_stats(int x) { Cons_stats = x; } void s9_reset_counter(s9_counter *c) { c->n = 0; c->n1k = 0; c->n1m = 0; c->n1g = 0; c->n1t = 0; } void s9_count(s9_counter *c) { c->n++; if (c->n >= 1000) { c->n -= 1000; c->n1k++; if (c->n1k >= 1000) { c->n1k -= 1000; c->n1m++; if (c->n1m >= 1000) { c->n1m -= 1000; c->n1g++; if (c->n1g >= 1000) { c->n1g -= 1000; c->n1t++; } } } } } cell s9_read_counter(s9_counter *c) { cell n, m; n = s9_make_integer(c->n); n = cons(n, NIL); save(n); m = s9_make_integer(c->n1k); n = cons(m, n); car(Stack) = n; m = s9_make_integer(c->n1m); n = cons(m, n); car(Stack) = n; m = s9_make_integer(c->n1g); n = cons(m, n); car(Stack) = n; m = s9_make_integer(c->n1t); n = cons(m, n); s9_unsave(1); return n; } void s9_get_counters(s9_counter **nc, s9_counter **cc, s9_counter **gc) { *nc = &Nodes; *cc = &Conses; *gc = &Collections; } /* * Raw I/O */ int s9_readc(void) { int c, i; if (Str_inport != NULL) { for (i=1; i>=0; i--) { if (Rejected[i] > -1) { c = Rejected[i]; Rejected[i] = -1; return c; } } if (0 == *Str_inport) { return EOF; } else { return *Str_inport++; } } else { return getc(Ports[Input_port]); } } void s9_rejectc(int c) { if (Str_inport != NULL) { if (Rejected[0] == -1) Rejected[0] = c; else Rejected[1] = c; } else { ungetc(c, Ports[Input_port]); } } char *s9_open_input_string(char *s) { char *os; os = Str_inport; Str_inport = s; Rejected[0] = Rejected[1] = -1; return os; } void s9_close_input_string(void) { Str_inport = NULL; } void s9_flush(void) { if (fflush(Ports[Output_port])) IO_error = 1; } void s9_set_printer_limit(int k) { Printer_limit = k; Printer_count = 0; } int s9_printer_limit(void) { return Printer_limit && Printer_count >= Printer_limit; } void s9_blockwrite(char *s, int k) { if (Str_outport) { if (k >= Str_outport_len) { k = Str_outport_len; IO_error = 1; } memcpy(Str_outport, s, k); Str_outport += k; Str_outport_len -= k; *Str_outport = 0; return; } if (Printer_limit && Printer_count > Printer_limit) { if (Printer_limit > 0) fwrite("...", 1, 3, Ports[Output_port]); Printer_limit = -1; return; } if (fwrite(s, 1, k, Ports[Output_port]) != k) IO_error = 1; if (Output_port == 1 && s[k-1] == '\n') s9_flush(); Printer_count += k; } int s9_blockread(char *s, int k) { int n; n = fread(s, 1, k, Ports[Input_port]); if (n < 0) IO_error = 1; return n; } void s9_prints(char *s) { if (Ports[Output_port] == NULL) s9_fatal("pr: output port is not open"); s9_blockwrite(s, strlen(s)); } int s9_io_status(void) { return IO_error? -1: 0; } void s9_io_reset(void) { IO_error = 0; } /* * Error Handling */ void s9_fatal(char *msg) { fprintf(stderr, "S9core: s9_fatal error: "); fprintf(stderr, "%s\n", msg); bye(1); } /* * Memory Management */ void s9_set_node_limit(int n) { Node_limit = n * 1024L; } void s9_set_vector_limit(int n) { Vector_limit = n * 1024L; } void s9_gc_verbosity(int n) { Verbose_GC = n; } void s9_mem_error_handler(void (*h)(int src)) { Mem_error_handler = h; } static void new_cons_segment(void) { Car = realloc(Car, sizeof(cell)*(Cons_pool_size+Cons_segment_size)); Cdr = realloc(Cdr, sizeof(cell)*(Cons_pool_size+Cons_segment_size)); Tag = realloc(Tag, Cons_pool_size + Cons_segment_size); if (Car == NULL || Cdr == NULL || Tag == NULL) s9_fatal("new_cons_segment: out of physical memory"); memset(&car(Cons_pool_size), 0, Cons_segment_size * sizeof(cell)); memset(&cdr(Cons_pool_size), 0, Cons_segment_size * sizeof(cell)); memset(&Tag[Cons_pool_size], 0, Cons_segment_size); Cons_pool_size += Cons_segment_size; Cons_segment_size = Cons_pool_size / 2; } static void new_vec_segment(void) { Vectors = realloc(Vectors, sizeof(cell) * (Vec_pool_size + Vec_segment_size)); if (Vectors == NULL) s9_fatal("new_vec_segment: out of physical memory"); memset(&Vectors[Vec_pool_size], 0, Vec_segment_size * sizeof(cell)); Vec_pool_size += Vec_segment_size; Vec_segment_size = Vec_pool_size / 2; } /* * Mark nodes which can be accessed through N. * Using the Deutsch/Schorr/Waite pointer reversal algorithm. * S0: M==0, S==0, unvisited, process CAR (vectors: process 1st slot); * S1: M==1, S==1, CAR visited, process CDR (vectors: process next slot); * S2: M==1, S==0, completely visited, return to parent. */ static void mark(cell n) { cell p, parent, *v; int i; parent = NIL; /* Initially, there is no parent node */ while (1) { if (s9_special_p(n) || (Tag[n] & S9_MARK_TAG)) { if (parent == NIL) break; if (Tag[parent] & S9_VECTOR_TAG) { /* S1 --> S1|done */ i = vector_index(parent); v = vector(parent); if (Tag[parent] & S9_STATE_TAG && i+1 < vector_len(parent) ) { /* S1 --> S1 */ p = v[i+1]; v[i+1] = v[i]; v[i] = n; n = p; vector_index(parent) = i+1; } else { /* S1 --> done */ p = parent; parent = v[i]; v[i] = n; n = p; } } else if (Tag[parent] & S9_STATE_TAG) { /* S1 --> S2 */ p = cdr(parent); cdr(parent) = car(parent); car(parent) = n; Tag[parent] &= ~S9_STATE_TAG; Tag[parent] |= S9_MARK_TAG; n = p; } else { /* S2 --> done */ p = parent; parent = cdr(p); cdr(p) = n; n = p; } } else { if (Tag[n] & S9_VECTOR_TAG) { /* S0 --> S1|S2 */ Tag[n] |= S9_MARK_TAG; /* Tag[n] &= ~S9_STATE_TAG; */ vector_link(n) = n; if (car(n) == T_VECTOR && vector_len(n) != 0) { Tag[n] |= S9_STATE_TAG; vector_index(n) = 0; v = vector(n); p = v[0]; v[0] = parent; parent = n; n = p; } } else if (Tag[n] & S9_ATOM_TAG) { /* S0 --> S2 */ if (input_port_p(n) || output_port_p(n)) Port_flags[port_no(n)] |= S9_USED_TAG; p = cdr(n); cdr(n) = parent; /*Tag[n] &= ~S9_STATE_TAG;*/ parent = n; n = p; Tag[parent] |= S9_MARK_TAG; } else { /* S0 --> S1 */ p = car(n); car(n) = parent; Tag[n] |= S9_MARK_TAG; parent = n; n = p; Tag[parent] |= S9_STATE_TAG; } } } } /* Mark and sweep GC. */ int s9_gc(void) { int i, k; char buf[100]; if (Run_stats) s9_count(&Collections); for (i=0; i 1) { sprintf(buf, "GC: %d nodes reclaimed", k); s9_prints(buf); nl(); } return k; } /* Allocate a fresh node and initialize with PCAR,PCDR,PTAG. */ cell s9_cons3(cell pcar, cell pcdr, int ptag) { cell n; int k; char buf[100]; if (Run_stats) { s9_count(&Nodes); if (Cons_stats) s9_count(&Conses); } if (Free_list == NIL) { if (ptag == 0) Tmp_car = pcar; if (!(ptag & S9_VECTOR_TAG)) Tmp_cdr = pcdr; k = s9_gc(); /* * Performance increases dramatically if we * do not wait for the pool to run dry. * In fact, don't even let it come close to that. */ if (k < Cons_pool_size / 2) { if ( Node_limit && Cons_pool_size + Cons_segment_size > Node_limit ) { if (Mem_error_handler) (*Mem_error_handler)(1); else s9_fatal("s9_cons3: hit memory limit"); } else { new_cons_segment(); if (Verbose_GC) { sprintf(buf, "GC: new segment," " nodes = %d," " next segment = %d", Cons_pool_size, Cons_segment_size); s9_prints(buf); nl(); } s9_gc(); } } Tmp_car = Tmp_cdr = NIL; } if (Free_list == NIL) s9_fatal("s9_cons3: failed to recover from low memory condition"); n = Free_list; Free_list = cdr(Free_list); car(n) = pcar; cdr(n) = pcdr; Tag[n] = ptag; return n; } /* Mark all vectors unused */ static void unmark_vectors(void) { int p, k, link; p = 0; while (p < Free_vecs) { link = p; k = Vectors[p + RAW_VECTOR_SIZE]; p += vector_size(k); Vectors[link] = NIL; } } /* In situ vector pool garbage collection and compaction */ int s9_gcv(void) { int v, k, to, from; char buf[100]; unmark_vectors(); s9_gc(); /* re-mark live vectors */ to = from = 0; while (from < Free_vecs) { v = Vectors[from + RAW_VECTOR_SIZE]; k = vector_size(v); if (Vectors[from + RAW_VECTOR_LINK] != NIL) { if (to != from) { memmove(&Vectors[to], &Vectors[from], k * sizeof(cell)); cdr(Vectors[to + RAW_VECTOR_LINK]) = to + RAW_VECTOR_DATA; } to += k; } from += k; } k = Free_vecs - to; if (Verbose_GC > 1) { sprintf(buf, "GC: gcv: %d cells reclaimed", k); s9_prints(buf); nl(); } Free_vecs = to; return k; } /* Allocate vector from pool */ cell s9_new_vec(cell type, int size) { cell n; int i, v, wsize; char buf[100]; wsize = vector_size(size); if (Free_vecs + wsize >= Vec_pool_size) { s9_gcv(); while ( Free_vecs + wsize >= Vec_pool_size - Vec_pool_size / 2 ) { if ( Vector_limit && Vec_pool_size + Vec_segment_size > Vector_limit ) { if (Mem_error_handler) (*Mem_error_handler)(2); else s9_fatal("new_vec: hit memory limit"); break; } else { new_vec_segment(); s9_gcv(); if (Verbose_GC) { sprintf(buf, "GC: new_vec: new segment," " cells = %d", Vec_pool_size); s9_prints(buf); nl(); } } } } if (Free_vecs + wsize >= Vec_pool_size) s9_fatal("new_vec: failed to recover from low memory condition"); v = Free_vecs; Free_vecs += wsize; n = s9_cons3(type, v + RAW_VECTOR_DATA, S9_VECTOR_TAG); Vectors[v + RAW_VECTOR_LINK] = n; Vectors[v + RAW_VECTOR_INDEX] = 0; Vectors[v + RAW_VECTOR_SIZE] = size; if (type == T_VECTOR) { for (i = RAW_VECTOR_DATA; i S9_MANTISSA_SIZE) return UNDEFINED; return S9_make_real(sign < 0? REAL_NEGATIVE: 0, exp, cdr(mant)); } static void grow_primitives(void) { Max_prims += S9_PRIM_SEG_SIZE; Primitives = (S9_PRIM *) realloc(Primitives, sizeof(S9_PRIM) * Max_prims); if (Primitives == NULL) s9_fatal("grow_primitives: out of physical memory"); } cell s9_make_primitive(S9_PRIM *p) { cell n; n = new_atom(Last_prim, NIL); n = new_atom(T_PRIMITIVE, n); if (Last_prim >= Max_prims) grow_primitives(); memcpy(&Primitives[Last_prim], p, sizeof(S9_PRIM)); Last_prim++; return n; } cell s9_make_port(int portno, cell type) { cell n; int pf; pf = Port_flags[portno]; Port_flags[portno] |= S9_LOCK_TAG; n = new_atom(portno, NIL); n = s9_cons3(type, n, S9_ATOM_TAG|S9_PORT_TAG); Port_flags[portno] = pf; return n; } cell s9_string_to_symbol(cell x) { cell y, n, k; y = s9_find_symbol(string(x)); if (y != NIL) return y; /* * Cannot pass content to s9_make_symbol(), because * string(x) may move during GC. */ k = string_len(x); n = s9_make_symbol("", k-1); memcpy(symbol_name(n), string(x), k); return s9_intern_symbol(n); } cell s9_symbol_to_string(cell x) { cell n, k; /* * Cannot pass name to s9_make_string(), because * symbol_name(x) may move during GC. */ k = symbol_len(x); n = s9_make_string("", k-1); memcpy(string(n), symbol_name(x), k); return n; } cell s9_copy_string(cell x) { cell n, k; /* * See s9_string_to_symbol(), above. */ k = string_len(x); n = s9_make_string("", k-1); memcpy(string(n), string(x), k); return n; } /* * Miscellanea */ int s9_length(cell n) { int k; for (k = 0; n != NIL; n = cdr(n)) k++; return k; } cell s9_flat_copy(cell n, cell *lastp) { cell a, m, last, new; if (n == NIL) { if (lastp != NULL) lastp[0] = NIL; return NIL; } m = s9_cons3(NIL, NIL, Tag[n]); save(m); a = m; last = m; while (n != NIL) { car(a) = car(n); last = a; n = cdr(n); if (n != NIL) { new = s9_cons3(NIL, NIL, Tag[n]); cdr(a) = new; a = cdr(a); } } s9_unsave(1); if (lastp != NULL) lastp[0] = last; return m; } long s9_asctol(char *s) { while (*s == '0' && s[1]) s++; return atol(s); } static char *ntoa(char *b, cell x, int w) { char buf[40]; int i = 0, neg = 0; char *p = &buf[sizeof(buf)-1]; if (x < 0) { x = -x; neg = 1; } *p = 0; while (x || i == 0) { i++; if (i >= sizeof(buf)-1) s9_fatal("ntoa: number too big"); p--; *p = x % 10 + '0'; x = x / 10; } while (i < (w-neg) && i < sizeof(buf)-1) { i++; p--; *p = '0'; } if (neg) { if (i >= sizeof(buf)-1) s9_fatal("ntoa: number too big"); p--; *p = '-'; } strcpy(b, p); return b; } cell s9_argv_to_list(char **argv) { int i; cell a, n; if (argv[0] == NULL) return NIL; a = cons(NIL, NIL); save(a); for (i = 0; argv[i] != NULL; i++) { n = s9_make_string(argv[i], strlen(argv[i])); car(a) = n; if (argv[i+1] != NULL) { n = cons(NIL, NIL); cdr(a) = n; a = cdr(a); } } return s9_unsave(1); } /* * Bignums */ cell s9_bignum_abs(cell a) { cell n; save(a); n = new_atom(labs(cadr(a)), cddr(a)); n = new_atom(T_INTEGER, n); s9_unsave(1); return n; } cell s9_bignum_negate(cell a) { cell n; save(a); n = new_atom(-cadr(a), cddr(a)); n = new_atom(T_INTEGER, n); s9_unsave(1); return n; } static cell reverse_segments(cell n) { cell m; m = NIL; while (n != NIL) { m = new_atom(car(n), m); n = cdr(n); } return m; } int s9_bignum_even_p(cell a) { while (cdr(a) != NIL) a = cdr(a); return car(a) % 2 == 0; } cell s9_bignum_add(cell a, cell b); cell s9_bignum_subtract(cell a, cell b); static cell Bignum_add(cell a, cell b) { cell fa, fb, result, r; int carry; if (bignum_negative_p(a)) { if (bignum_negative_p(b)) { /* -A+-B --> -(|A|+|B|) */ a = s9_bignum_abs(a); save(a); a = s9_bignum_add(a, s9_bignum_abs(b)); s9_unsave(1); return s9_bignum_negate(a); } else { /* -A+B --> B-|A| */ return s9_bignum_subtract(b, s9_bignum_abs(a)); } } else if (bignum_negative_p(b)) { /* A+-B --> A-|B| */ return s9_bignum_subtract(a, s9_bignum_abs(b)); } /* A+B */ a = reverse_segments(cdr(a)); save(a); b = reverse_segments(cdr(b)); save(b); carry = 0; result = NIL; save(result); while (a != NIL || b != NIL || carry) { fa = a == NIL? 0: car(a); fb = b == NIL? 0: car(b); r = fa + fb + carry; carry = 0; if (r >= S9_INT_SEG_LIMIT) { r -= S9_INT_SEG_LIMIT; carry = 1; } result = new_atom(r, result); car(Stack) = result; if (a != NIL) a = cdr(a); if (b != NIL) b = cdr(b); } s9_unsave(3); return new_atom(T_INTEGER, result); } cell s9_bignum_add(cell a, cell b) { Tmp = b; save(a); save(b); Tmp = NIL; a = Bignum_add(a, b); s9_unsave(2); return a; } int s9_bignum_less_p(cell a, cell b) { int ka, kb, neg_a, neg_b; neg_a = bignum_negative_p(a); neg_b = bignum_negative_p(b); if (neg_a && !neg_b) return 1; if (!neg_a && neg_b) return 0; ka = s9_length(a); kb = s9_length(b); if (ka < kb) return neg_a? 0: 1; if (ka > kb) return neg_a? 1: 0; Tmp = b; a = s9_bignum_abs(a); save(a); b = s9_bignum_abs(b); s9_unsave(1); Tmp = NIL; a = cdr(a); b = cdr(b); while (a != NIL) { if (car(a) < car(b)) return neg_a? 0: 1; if (car(a) > car(b)) return neg_a? 1: 0; a = cdr(a); b = cdr(b); } return 0; } int s9_bignum_equal_p(cell a, cell b) { a = cdr(a); b = cdr(b); while (a != NIL && b != NIL) { if (car(a) != car(b)) return 0; a = cdr(a); b = cdr(b); } return a == NIL && b == NIL; } static cell Bignum_subtract(cell a, cell b) { cell fa, fb, result, r; int borrow; if (bignum_negative_p(a)) { if (bignum_negative_p(b)) { /* -A--B --> -A+|B| --> |B|-|A| */ a = s9_bignum_abs(a); save(a); a = s9_bignum_subtract(s9_bignum_abs(b), a); s9_unsave(1); return a; } else { /* -A-B --> -(|A|+B) */ return s9_bignum_negate( s9_bignum_add(s9_bignum_abs(a), b)); } } else if (bignum_negative_p(b)) { /* A--B --> A+|B| */ return s9_bignum_add(a, s9_bignum_abs(b)); } /* A-B, A -(B-A) */ if (s9_bignum_less_p(a, b)) return s9_bignum_negate(s9_bignum_subtract(b, a)); /* A-B, A>=B */ a = reverse_segments(cdr(a)); save(a); b = reverse_segments(cdr(b)); save(b); borrow = 0; result = NIL; save(result); while (a != NIL || b != NIL || borrow) { fa = a == NIL? 0: car(a); fb = b == NIL? 0: car(b); r = fa - fb - borrow; borrow = 0; if (r < 0) { r += S9_INT_SEG_LIMIT; borrow = 1; } result = new_atom(r, result); car(Stack) = result; if (a != NIL) a = cdr(a); if (b != NIL) b = cdr(b); } s9_unsave(3); while (car(result) == 0 && cdr(result) != NIL) result = cdr(result); return new_atom(T_INTEGER, result); } cell s9_bignum_subtract(cell a, cell b) { Tmp = b; save(a); save(b); Tmp = NIL; a = Bignum_subtract(a, b); s9_unsave(2); return a; } cell s9_bignum_shift_left(cell a, int fill) { cell r, c, result; int carry; save(a); a = reverse_segments(cdr(a)); save(a); carry = fill; result = NIL; save(result); while (a != NIL) { if (car(a) >= S9_INT_SEG_LIMIT/10) { c = car(a) / (S9_INT_SEG_LIMIT/10); r = car(a) % (S9_INT_SEG_LIMIT/10) * 10; r += carry; carry = c; } else { r = car(a) * 10 + carry; carry = 0; } result = new_atom(r, result); car(Stack) = result; a = cdr(a); } if (carry) result = new_atom(carry, result); result = new_atom(T_INTEGER, result); s9_unsave(3); return result; } /* Result: (a/10 . a%10) */ cell s9_bignum_shift_right(cell a) { cell r, c, result; int carry; save(a); a = cdr(a); save(a); carry = 0; result = NIL; save(result); while (a != NIL) { c = car(a) % 10; r = car(a) / 10; r += carry * (S9_INT_SEG_LIMIT/10); carry = c; result = new_atom(r, result); car(Stack) = result; a = cdr(a); } result = reverse_segments(result); if (car(result) == 0 && cdr(result) != NIL) result = cdr(result); result = new_atom(T_INTEGER, result); car(Stack) = result; carry = s9_make_integer(carry); result = cons(result, carry); s9_unsave(3); return result; } cell s9_bignum_multiply(cell a, cell b) { int neg; cell r, i, result; Tmp = b; save(a); save(b); Tmp = NIL; neg = bignum_negative_p(a) != bignum_negative_p(b); a = s9_bignum_abs(a); save(a); b = s9_bignum_abs(b); save(b); result = Zero; save(result); while (!bignum_zero_p(a)) { r = s9_bignum_shift_right(a); i = caddr(r); a = car(r); caddr(Stack) = a; while (i) { if (Error) { s9_unsave(5); return Zero; } result = s9_bignum_add(result, b); car(Stack) = result; i--; } b = s9_bignum_shift_left(b, 0); cadr(Stack) = b; } if (neg) result = s9_bignum_negate(result); s9_unsave(5); return result; } /* * Equalize A and B, e.g.: * A=123, B=12345 --> 12300, 100 * Return (scaled-a . scaling-factor) */ static cell bignum_equalize(cell a, cell b) { cell r, f, r0, f0; r0 = a; save(r0); f0 = One; save(f0); r = r0; save(r); f = f0; save(f); while (s9_bignum_less_p(r, b)) { cadddr(Stack) = r0 = r; caddr(Stack) = f0 = f; r = s9_bignum_shift_left(r, 0); cadr(Stack) = r; f = s9_bignum_shift_left(f, 0); car(Stack) = f; } s9_unsave(4); return cons(r0, f0); } /* Result: (a/b . a%b) */ static cell Bignum_divide(cell a, cell b) { int neg, neg_a; cell result, f; int i; cell c, c0; neg_a = bignum_negative_p(a); neg = neg_a != bignum_negative_p(b); a = s9_bignum_abs(a); save(a); b = s9_bignum_abs(b); save(b); if (s9_bignum_less_p(a, b)) { if (neg_a) a = s9_bignum_negate(a); s9_unsave(2); return cons(Zero, a); } b = bignum_equalize(b, a); cadr(Stack) = b; /* cadr+cddddr */ car(Stack) = a; /* car+cddddr */ c = NIL; save(c); /* cadddr */ c0 = NIL; save(c0); /* caddr */ f = cdr(b); b = car(b); cadddr(Stack) = b; save(f); /* cadr */ result = Zero; save(result); /* car */ while (!bignum_zero_p(f)) { c = Zero; cadddr(Stack) = c; caddr(Stack) = c0 = c; i = 0; while (!s9_bignum_less_p(a, c)) { caddr(Stack) = c0 = c; c = s9_bignum_add(c, b); cadddr(Stack) = c; i++; } result = s9_bignum_shift_left(result, i-1); car(Stack) = result; a = s9_bignum_subtract(a, c0); car(cddddr(Stack)) = a; f = s9_bignum_shift_right(f); f = car(f); cadr(Stack) = f; b = s9_bignum_shift_right(b); b = car(b); cadr(cddddr(Stack)) = b; } if (neg) result = s9_bignum_negate(result); car(Stack) = result; if (neg_a) a = s9_bignum_negate(a); s9_unsave(6); return cons(result, a); } cell s9_bignum_divide(cell a, cell b) { if (bignum_zero_p(b)) return UNDEFINED; Tmp = b; save(a); save(b); Tmp = NIL; a = Bignum_divide(a, b); s9_unsave(2); return a; } /* * Real Number Arithmetics */ static cell count_digits(cell m) { int k; cell x; x = car(m); k = 0; while (x != 0) { x /= 10; k++; } k = k==0? 1: k; m = cdr(m); while (m != NIL) { k += S9_DIGITS_PER_CELL; m = cdr(m); } return k; } cell s9_real_exponent(cell x) { if (integer_p(x)) return Zero; return Real_exponent(x); } cell s9_real_mantissa(cell x) { cell m; if (integer_p(x)) return x; m = new_atom(T_INTEGER, Real_mantissa(x)); if (Real_negative_p(x)) m = s9_bignum_negate(m); return m; } /* * Remove trailing zeros and move the decimal * point to the END of the mantissa, e.g.: * real_normalize(1.234e0) --> 1234e-3 * * Limit the mantissa to S9_MANTISSA_SEGMENTS * machine words. This may cause a loss of * precision. * * Also handle numeric overflow/underflow. */ static cell real_normalize(cell x) { cell m, e, r; int dgs; save(x); e = Real_exponent(x); m = new_atom(T_INTEGER, Real_mantissa(x)); save(m); dgs = count_digits(cdr(m)); while (dgs > S9_MANTISSA_SIZE) { r = s9_bignum_shift_right(m); m = car(r); car(Stack) = m; dgs--; e++; } while (!bignum_zero_p(m)) { r = s9_bignum_shift_right(m); if (!bignum_zero_p(cdr(r))) break; m = car(r); car(Stack) = m; e++; } if (bignum_zero_p(m)) e = 0; r = new_atom(e, NIL); if (count_digits(r) > S9_DIGITS_PER_CELL) { s9_unsave(2); return UNDEFINED; } r = S9_make_quick_real(Real_flags(x), e, cdr(m)); s9_unsave(2); return r; } cell s9_bignum_to_real(cell a) { int e, flags, d; cell m, n; save(a); m = s9_flat_copy(a, NULL); cadr(m) = labs(cadr(m)); e = 0; if (s9_length(cdr(m)) > S9_MANTISSA_SEGMENTS) { d = count_digits(cdr(m)); while (d > S9_MANTISSA_SIZE) { m = s9_bignum_shift_right(m); m = car(m); e++; d--; } } flags = bignum_negative_p(a)? REAL_NEGATIVE: 0; n = S9_make_quick_real(flags, e, cdr(m)); n = real_normalize(n); s9_unsave(1); return n; } cell s9_real_negate(cell a) { if (integer_p(a)) return s9_bignum_negate(a); Tmp = a; a = Real_negate(a); Tmp = NIL; return a; } cell s9_real_negative_p(cell a) { if (integer_p(a)) return bignum_negative_p(a); return Real_negative_p(a); } cell s9_real_positive_p(cell a) { if (integer_p(a)) return bignum_positive_p(a); return Real_positive_p(a); } cell s9_real_zero_p(cell a) { if (integer_p(a)) return bignum_zero_p(a); return Real_zero_p(a); } cell s9_real_abs(cell a) { if (integer_p(a)) return s9_bignum_abs(a); if (Real_negative_p(a)) { Tmp = a; a = Real_negate(a); Tmp = NIL; return a; } return a; } int s9_real_equal_p(cell a, cell b) { cell ma, mb; if (integer_p(a) && integer_p(b)) return s9_bignum_equal_p(a, b); Tmp = b; save(a); save(b); Tmp = NIL; if (integer_p(a)) a = s9_bignum_to_real(a); if (integer_p(b)) { save(a); b = s9_bignum_to_real(b); s9_unsave(1); } s9_unsave(2); if (Real_exponent(a) != Real_exponent(b)) return 0; if (Real_zero_p(a) && Real_zero_p(b)) return 1; if (Real_negative_p(a) != Real_negative_p(b)) return 0; ma = Real_mantissa(a); mb = Real_mantissa(b); while (ma != NIL && mb != NIL) { if (car(ma) != car(mb)) return 0; ma = cdr(ma); mb = cdr(mb); } if (ma != mb) return 0; return 1; } /* * Scale the number R so that it gets exponent DESIRED_E * without changing its value. When there is not enough * room for scaling the mantissa of R, return UNDEFINED. * E.g.: scale_mantissa(1.0e0, -2, 0) --> 100.0e-2 * * Allow the mantissa to grow to MAX_SIZE segments. */ static cell scale_mantissa(cell r, cell desired_e, int max_size) { int dgs; cell n, e; dgs = count_digits(Real_mantissa(r)); if (max_size && (max_size - dgs < Real_exponent(r) - desired_e)) return UNDEFINED; n = new_atom(T_INTEGER, s9_flat_copy(Real_mantissa(r), NULL)); save(n); e = Real_exponent(r); while (e > desired_e) { n = s9_bignum_shift_left(n, 0); car(Stack) = n; e--; } s9_unsave(1); return S9_make_quick_real(Real_flags(r), e, cdr(n)); } static void autoscale(cell *pa, cell *pb) { if (Real_exponent(*pa) < Real_exponent(*pb)) { *pb = scale_mantissa(*pb, Real_exponent(*pa), S9_MANTISSA_SIZE*2); return; } if (Real_exponent(*pa) > Real_exponent(*pb)) { *pa = scale_mantissa(*pa, Real_exponent(*pb), S9_MANTISSA_SIZE*2); } } int s9_real_less_p(cell a, cell b) { cell ma, mb; int ka, kb, neg; int dpa, dpb; if (integer_p(a) && integer_p(b)) return s9_bignum_less_p(a, b); Tmp = b; save(a); save(b); Tmp = NIL; if (integer_p(a)) a = s9_bignum_to_real(a); if (integer_p(b)) { save(a); b = s9_bignum_to_real(b); s9_unsave(1); } s9_unsave(2); if (Real_negative_p(a) && !Real_negative_p(b)) return 1; if (Real_negative_p(b) && !Real_negative_p(a)) return 0; if (Real_zero_p(a) && Real_positive_p(b)) return 1; if (Real_zero_p(b) && Real_positive_p(a)) return 0; neg = Real_negative_p(a); dpa = count_digits(Real_mantissa(a)) + Real_exponent(a); dpb = count_digits(Real_mantissa(b)) + Real_exponent(b); if (dpa < dpb) return neg? 0: 1; if (dpa > dpb) return neg? 1: 0; Tmp = b; save(a); save(b); Tmp = NIL; autoscale(&a, &b); s9_unsave(2); if (a == UNDEFINED) return neg? 1: 0; if (b == UNDEFINED) return neg? 0: 1; ma = Real_mantissa(a); mb = Real_mantissa(b); ka = s9_length(ma); kb = s9_length(mb); if (ka < kb) return 1; if (ka > kb) return 0; while (ma != NIL) { if (car(ma) < car(mb)) return neg? 0: 1; if (car(ma) > car(mb)) return neg? 1: 0; ma = cdr(ma); mb = cdr(mb); } return 0; } cell s9_real_add(cell a, cell b) { cell r, m, e, aa, ab; int flags, nega, negb; if (integer_p(a) && integer_p(b)) return s9_bignum_add(a, b); Tmp = b; save(a); save(b); Tmp = NIL; if (integer_p(a)) a = s9_bignum_to_real(a); save(a); if (integer_p(b)) b = s9_bignum_to_real(b); save(b); if (Real_zero_p(a)) { s9_unsave(4); return b; } if (Real_zero_p(b)) { s9_unsave(4); return a; } autoscale(&a, &b); if (a == UNDEFINED || b == UNDEFINED) { ab = s9_real_abs(car(Stack)); save(ab); aa = s9_real_abs(caddr(Stack)); s9_unsave(1); b = s9_unsave(1); a = s9_unsave(1); s9_unsave(2); return s9_real_less_p(aa, ab)? b: a; } cadr(Stack) = a; car(Stack) = b; e = Real_exponent(a); nega = Real_negative_p(a); negb = Real_negative_p(b); a = new_atom(T_INTEGER, Real_mantissa(a)); if (nega) a = s9_bignum_negate(a); cadr(Stack) = a; b = new_atom(T_INTEGER, Real_mantissa(b)); if (negb) b = s9_bignum_negate(b); car(Stack) = b; m = s9_bignum_add(a, b); flags = bignum_negative_p(m)? REAL_NEGATIVE: 0; r = s9_bignum_abs(m); r = S9_make_quick_real(flags, e, cdr(r)); r = real_normalize(r); s9_unsave(4); return r; } cell s9_real_subtract(cell a, cell b) { cell r; Tmp = b; save(a); save(b); Tmp = NIL; if (integer_p(b)) b = s9_bignum_negate(b); else b = Real_negate(b); save(b); r = s9_real_add(a, b); s9_unsave(3); return r; } cell s9_real_multiply(cell a, cell b) { cell r, m, e, ma, mb, ea, eb, neg; if (integer_p(a) && integer_p(b)) return s9_bignum_multiply(a, b); Tmp = b; save(a); save(b); Tmp = NIL; if (integer_p(a)) a = s9_bignum_to_real(a); save(a); if (integer_p(b)) b = s9_bignum_to_real(b); save(b); neg = Real_negative_flag(a) != Real_negative_flag(b); ea = Real_exponent(a); eb = Real_exponent(b); ma = new_atom(T_INTEGER, Real_mantissa(a)); cadr(Stack) = ma; mb = new_atom(T_INTEGER, Real_mantissa(b)); car(Stack) = mb; e = ea + eb; m = s9_bignum_multiply(ma, mb); r = S9_make_quick_real(neg? REAL_NEGATIVE: 0, e, cdr(m)); r = real_normalize(r); s9_unsave(4); return r; } cell s9_real_divide(cell a, cell b) { cell r, m, e, ma, mb, ea, eb, neg, div2; int nd, dd; Tmp = b; save(a); save(b); Tmp = NIL; if (integer_p(a)) a = s9_bignum_to_real(a); save(a); if (integer_p(b)) b = s9_bignum_to_real(b); save(b); if (Real_zero_p(b)) { s9_unsave(4); return UNDEFINED; } if (Real_zero_p(a)) { r = S9_make_quick_real(0, 0, cdr(Zero)); s9_unsave(4); return r; } neg = Real_negative_flag(a) != Real_negative_flag(b); ea = Real_exponent(a); eb = Real_exponent(b); ma = new_atom(T_INTEGER, Real_mantissa(a)); cadr(Stack) = ma; mb = new_atom(T_INTEGER, Real_mantissa(b)); car(Stack) = mb; if (bignum_zero_p(mb)) { s9_unsave(4); return UNDEFINED; } nd = count_digits(cdr(ma)); dd = S9_MANTISSA_SIZE + count_digits(cdr(mb)); while (nd < dd) { ma = s9_bignum_shift_left(ma, 0); cadr(Stack) = ma; nd++; ea--; } e = ea - eb; m = s9_bignum_divide(ma, mb); save(m); div2 = s9_bignum_abs(mb); div2 = s9_bignum_divide(div2, Two); div2 = car(div2); if (s9_bignum_less_p(div2, cdr(m))) { m = s9_bignum_add(car(m), One); } else { m = car(m); } r = S9_make_quick_real(neg? REAL_NEGATIVE: 0, e, cdr(m)); r = real_normalize(r); s9_unsave(5); return r; } cell s9_real_sqrt(cell x) { cell n0, n1, d; int r; if (s9_real_negative_p(x)) return UNDEFINED; if (s9_real_zero_p(x)) return Zero; save(x); n0 = x; save(n0); while (1) { n1 = s9_real_divide(x, n0); if (n1 == UNDEFINED) break; n1 = s9_real_add(n1, n0); n1 = s9_real_divide(n1, Two); save(n1); d = s9_real_subtract(n0, n1); d = s9_real_abs(d); r = s9_real_less_p(d, Epsilon); n0 = s9_unsave(1); if (r) { break; } car(Stack) = n0; } s9_unsave(2); return n1; } /* * Real power algorithm from * http://stackoverflow.com/questions/3518973 * Thanks, Tom Sirgedas! */ static cell rpower(cell x, cell y, cell prec) { cell n, nprec; if (Error) return Zero; if (s9_real_equal_p(y, One)) return x; if (!s9_real_less_p(y, Ten)) { save(x); n = s9_real_divide(y, Two); car(Stack) = n; nprec = s9_real_divide(prec, Two); save(nprec); n = rpower(x, n, nprec); if (n == UNDEFINED || Error) { s9_unsave(2); return UNDEFINED; } s9_unsave(1); car(Stack) = n; n = s9_real_multiply(n, n); s9_unsave(1); return n; } if (!s9_real_less_p(y, One)) { y = s9_real_subtract(y, One); save(y); n = rpower(x, y, prec); if (n == UNDEFINED || Error) { s9_unsave(1); return UNDEFINED; } s9_unsave(1); n = s9_real_multiply(x, n); return n; } if (!s9_real_less_p(prec, One)) return s9_real_sqrt(x); y = s9_real_multiply(y, Two); save(y); nprec = s9_real_multiply(prec, Two); save(nprec); n = rpower(x, y, nprec); if (n == UNDEFINED || Error) { s9_unsave(2); return UNDEFINED; } s9_unsave(2); return s9_real_sqrt(n); } static cell npower(cell x, cell y) { cell n; int even; if (Error) return Zero; if (s9_real_zero_p(y)) return One; if (s9_real_equal_p(y, One)) return x; save(x); n = s9_bignum_divide(y, Two); even = bignum_zero_p(cdr(n)); car(Stack) = n; n = npower(x, car(n)); if (Error) { s9_unsave(1); return Zero; } car(Stack) = n; n = s9_real_multiply(n, n); car(Stack) = n; if (!even) { n = s9_real_multiply(x, n); car(Stack) = n; } s9_unsave(1); return n; } cell s9_real_power(cell x, cell y) { Tmp = x; save(y); save(x); Tmp = NIL; if (integer_p(y)) { x = npower(x, y); if (bignum_negative_p(y)) x = s9_real_divide(One, x); s9_unsave(2); if (s9_real_p(x)) { y = s9_real_to_bignum(x); if (y != UNDEFINED) x = y; } return x; } if (s9_real_negative_p(y)) { y = s9_real_abs(y); save(y); x = rpower(x, y, Epsilon); s9_unsave(3); if (x == UNDEFINED) return x; return s9_real_divide(One, x); } x = rpower(x, y, Epsilon); s9_unsave(2); if (real_p(x)) { y = s9_real_to_bignum(x); if (y != UNDEFINED) x = y; } return x; } /* type: 0=trunc, 1=floor, 2=ceil */ static cell rround(cell x, int type) { cell n, m, e; e = s9_real_exponent(x); if (e >= 0) return x; save(x); m = new_atom(T_INTEGER, Real_mantissa(x)); save(m); while (e < 0) { m = s9_bignum_shift_right(m); m = car(m); car(Stack) = m; e++; } if ( (type == 1 && Real_negative_p(x)) || (type == 2 && Real_positive_p(x)) ) { m = s9_bignum_add(m, One); } n = S9_make_real(Real_flags(x), e, cdr(m)); s9_unsave(2); return n; } cell s9_real_trunc(cell x) { return rround(x, 0); } cell s9_real_floor(cell x) { return rround(x, 1); } cell s9_real_ceil (cell x) { return rround(x, 2); } cell s9_real_to_bignum(cell r) { cell n; int neg; if (Real_exponent(r) >= 0) { save(r); neg = Real_negative_p(r); n = scale_mantissa(r, 0, 0); if (n == UNDEFINED) { s9_unsave(1); return UNDEFINED; } n = new_atom(T_INTEGER, Real_mantissa(n)); if (neg) n = s9_bignum_negate(n); s9_unsave(1); return n; } return UNDEFINED; } cell s9_real_integer_p(cell x) { if (integer_p(x)) return 1; if (real_p(x) && s9_real_to_bignum(x) != UNDEFINED) return 1; return 0; } /* * String/number conversion */ static int exponent_char_p(int c) { return c && strchr(Exponent_chars, c) != NULL; } int s9_integer_string_p(char *s) { if (*s == '-' || *s == '+') s++; if (!*s) return 0; while (isdigit(*s)) s++; return *s == 0; } int s9_string_numeric_p(char *s) { int i; int got_point = 0, got_digit = 0; i = 0; if (s[0] == '+' || s[0] == '-') i = 1; if (!s[i]) return 0; while (s[i]) { if (isdigit(s[i])) { got_digit = 1; i++; } else if (s[i] == '.' && !got_point) { got_point = 1; i++; } else { break; } } if (!got_digit) return 0; if (s[i] && strchr(Exponent_chars, s[i])) return s9_integer_string_p(&s[i+1]); return s[i] == 0; } cell s9_string_to_bignum(char *s) { cell n, v, str; int k, j, sign; sign = 1; if (s[0] == '-') { s++; sign = -1; } else if (s[0] == '+') { s++; } str = s9_make_string(s, strlen(s)); save(str); s = string(str); k = (int) strlen(s); n = NIL; while (k) { j = k <= S9_DIGITS_PER_CELL? k: S9_DIGITS_PER_CELL; v = s9_asctol(&s[k-j]); s[k-j] = 0; k -= j; n = new_atom(v, n); s = string(str); } s9_unsave(1); car(n) = sign * car(n); return new_atom(T_INTEGER, n); } cell s9_string_to_real(char *s) { cell mantissa, n; cell exponent; int found_dp; int neg = 0; int i, j, v; mantissa = Zero; save(mantissa); exponent = 0; i = 0; if (s[i] == '+') { i++; } else if (s[i] == '-') { neg = 1; i++; } found_dp = 0; while (isdigit((int) s[i]) || s[i] == '#' || s[i] == '.') { if (s[i] == '.') { i++; found_dp = 1; continue; } if (found_dp) exponent--; mantissa = s9_bignum_shift_left(mantissa, 0); car(Stack) = mantissa; if (s[i] == '#') v = 5; else v = s[i]-'0'; mantissa = s9_bignum_add(mantissa, s9_make_integer(v)); car(Stack) = mantissa; i++; } j = 0; for (n = cdr(mantissa); n != NIL; n = cdr(n)) j++; if (exponent_char_p(s[i])) { i++; if (!isdigit(s[i]) && s[i] != '-' && s[i] != '+') { s9_unsave(1); return UNDEFINED; } n = s9_string_to_bignum(&s[i]); if (cddr(n) != NIL) { s9_unsave(1); return UNDEFINED; } exponent += cadr(n); } s9_unsave(1); n = S9_make_quick_real((neg? REAL_NEGATIVE: 0), exponent, cdr(mantissa)); return real_normalize(n); } cell s9_string_to_number(char *s) { if (s9_integer_string_p(s)) return s9_string_to_bignum(s); else return s9_string_to_real(s); } void s9_print_bignum(cell n) { int first; char buf[S9_DIGITS_PER_CELL+2]; n = cdr(n); first = 1; while (n != NIL) { s9_prints(ntoa(buf, car(n), first? 0: S9_DIGITS_PER_CELL)); n = cdr(n); first = 0; } } void s9_print_expanded_real(cell n) { char buf[S9_DIGITS_PER_CELL+3]; int k, first; int dp_offset, old_offset; cell m, e; int n_digits, neg; m = Real_mantissa(n); e = Real_exponent(n); neg = Real_negative_p(n); n_digits = count_digits(m); dp_offset = e+n_digits; if (neg) s9_prints("-"); if (dp_offset <= 0) s9_prints("0"); if (dp_offset < 0) s9_prints("."); while (dp_offset < 0) { s9_prints("0"); dp_offset++; } dp_offset = e+n_digits; first = 1; while (m != NIL) { ntoa(buf, labs(car(m)), first? 0: S9_DIGITS_PER_CELL); k = strlen(buf); old_offset = dp_offset; dp_offset -= k; if (dp_offset < 0 && old_offset >= 0) { memmove(&buf[k+dp_offset+1], &buf[k+dp_offset], -dp_offset+1); buf[k+dp_offset] = '.'; } s9_prints(buf); m = cdr(m); first = 0; } if (dp_offset >= 0) { while (dp_offset > 0) { s9_prints("0"); dp_offset--; } s9_prints(".0"); } } void s9_print_sci_real(cell n) { int n_digits; cell m, e; char buf[S9_DIGITS_PER_CELL+2]; char es[2]; m = Real_mantissa(n); e = Real_exponent(n); n_digits = count_digits(m); if (Real_negative_flag(n)) s9_prints("-"); ntoa(buf, car(m), 0); s9_blockwrite(buf, 1); s9_prints("."); s9_prints(buf[1] || cdr(m) != NIL? &buf[1]: "0"); m = cdr(m); while (m != NIL) { s9_prints(ntoa(buf, car(m), S9_DIGITS_PER_CELL)); m = cdr(m); } es[0] = Exponent_chars[0]; es[1] = 0; s9_prints(es); if (e+n_digits-1 >= 0) s9_prints("+"); s9_prints(ntoa(buf, e+n_digits-1, 0)); } void s9_print_real(cell n) { int n_digits; cell m, e; m = Real_mantissa(n); e = Real_exponent(n); n_digits = count_digits(m); if (e+n_digits > -S9_MANTISSA_SIZE && e+n_digits <= S9_MANTISSA_SIZE) { s9_print_expanded_real(n); return; } s9_print_sci_real(n); } cell s9_bignum_to_int(cell x) { if (cddr(x) != NIL) return UNDEFINED; return cadr(x); } cell s9_bignum_to_string(cell x) { int n; cell s; int ioe; save(x); n = count_digits(cdr(x)); if (bignum_negative_p(x)) n++; s = s9_make_string("", n); Str_outport = string(s); Str_outport_len = n+1; ioe = IO_error; IO_error = 0; s9_print_bignum(x); n = IO_error; IO_error = ioe; Str_outport = NULL; Str_outport_len = 0; s9_unsave(1); if (n) { return UNDEFINED; } return s; } cell s9_real_to_string(cell x, int mode) { #define Z S9_MANTISSA_SIZE+S9_DIGITS_PER_CELL+10 char buf[Z]; int ioe, n; Str_outport = buf; Str_outport_len = Z; ioe = IO_error; IO_error = 0; switch (mode) { case 0: s9_print_real(x); break; case 1: s9_print_sci_real(x); break; case 2: s9_print_expanded_real(x); break; default: Str_outport = NULL; Str_outport_len = 0; return UNDEFINED; break; } Str_outport = NULL; Str_outport_len = 0; n = IO_error; IO_error = ioe; if (n) { return UNDEFINED; } return s9_make_string(buf, strlen(buf)); } /* * I/O */ void s9_close_port(int port) { if (port < 0 || port >= S9_MAX_PORTS) return; if (Ports[port] == NULL) { Port_flags[port] = 0; return; } fclose(Ports[port]); /* already closed? don't care */ Ports[port] = NULL; Port_flags[port] = 0; } int s9_new_port(void) { int i, tries; for (tries=0; tries<2; tries++) { for (i=0; i= S9_MAX_PORTS) return -1; return feof(Ports[p]); } int s9_input_port(void) { return Str_inport? -1: Input_port; } int s9_output_port(void) { return Output_port; } cell s9_set_input_port(cell port) { cell p = Input_port; Input_port = port; return p; } cell s9_set_output_port(cell port) { cell p = Output_port; Output_port = port; return p; } void s9_reset_std_ports(void) { clearerr(stdin); clearerr(stdout); clearerr(stderr); Input_port = 0; Output_port = 1; Error_port = 2; } int s9_lock_port(int port) { if (port < 0 || port >= S9_MAX_PORTS) return -1; Port_flags[port] |= S9_LOCK_TAG; return 0; } int s9_unlock_port(int port) { if (port < 0 || port >= S9_MAX_PORTS) return -1; Port_flags[port] &= ~S9_LOCK_TAG; return 0; } /* * Primitives */ static char *expected(int n, cell who, char *what, cell got) { static char msg[100]; S9_PRIM *p; p = &Primitives[cadr(who)]; sprintf(msg, "%s: expected %s in argument #%d", p->name, what, n); return msg; } static char *wrongargs(char *name, char *what) { static char buf[100]; sprintf(buf, "%s: too %s arguments", name, what); return buf; } char *s9_typecheck(cell f, cell a) { S9_PRIM *p; int k, na, i; p = prim_info(f); k = s9_length(a); if (k < p->min_args) return wrongargs(p->name, "few"); if (k > p->max_args && p->max_args >= 0) return wrongargs(p->name, "many"); na = p->max_args < 0? p->min_args: p->max_args; if (na > k) na = k; else if (na > 3) na = 3; for (i=1; i<=na; i++) { switch (p->arg_types[i-1]) { case T_ANY: break; case T_BOOLEAN: if (!boolean_p(car(a))) return expected(i, f, "boolean", car(a)); break; case T_CHAR: if (!char_p(car(a))) return expected(i, f, "char", car(a)); break; case T_INPUT_PORT: if (!input_port_p(car(a))) return expected(i, f, "input-port", car(a)); break; case T_INTEGER: if (!integer_p(car(a))) return expected(i, f, "integer", car(a)); break; case T_OUTPUT_PORT: if (!output_port_p(car(a))) return expected(i, f, "output-port", car(a)); break; case T_PAIR: if (atom_p(car(a))) return expected(i, f, "pair", car(a)); break; case T_LIST: if (car(a) != NIL && atom_p(car(a))) return expected(i, f, "list", car(a)); break; case T_FUNCTION: if ( !function_p(car(a)) && !primitive_p(car(a)) && !continuation_p(car(a)) ) return expected(i, f, "function", car(a)); break; case T_REAL: if (!integer_p(car(a)) && !real_p(car(a))) return expected(i, f, "number", car(a)); break; case T_STRING: if (!string_p(car(a))) return expected(i, f, "string", car(a)); break; case T_SYMBOL: if (!symbol_p(car(a))) return expected(i, f, "symbol", car(a)); break; case T_VECTOR: if (!vector_p(car(a))) return expected(i, f, "vector", car(a)); break; } a = cdr(a); } return NULL; } cell s9_apply_prim(cell f, cell a) { S9_PRIM *p; p = prim_info(f); return (*p->handler)(a); } /* * Image I/O */ struct magic { char id[16]; /* "magic#" */ char version[8]; /* "yyyymmdd" */ char cell_size[1]; /* size + '0' */ char mantissa_size[1]; /* size + '0' */ char byte_order[8]; /* e.g. "4321" */ char prim_slots[8]; /* see code */ char pad[6]; }; static char *xfwrite(void *buf, int siz, int n, FILE *f) { if (fwrite(buf, siz, n, f) != n) { return "image file write error"; } return NULL; } char *s9_dump_image(char *path, char *magic) { FILE *f; cell n, **v; int i; struct magic m; char *s; f = fopen(path, "wb"); if (f == NULL) { return "cannot create image file"; } memset(&m, '_', sizeof(m)); strncpy(m.id, magic, sizeof(m.id)); strncpy(m.version, S9_VERSION, sizeof(m.version)); m.cell_size[0] = sizeof(cell)+'0'; m.mantissa_size[0] = S9_MANTISSA_SEGMENTS+'0'; #ifdef BITS_PER_WORD_64 n = 0x3132333435363738L; #else n = 0x31323334L; #endif memcpy(m.byte_order, &n, sizeof(n)>8? 8: sizeof(n)); n = Last_prim; memcpy(m.prim_slots, &n, sizeof(n)>8? 8: sizeof(n)); if ((s = xfwrite(&m, sizeof(m), 1, f)) != NULL) { fclose(f); return s; } i = Cons_pool_size; if ((s = xfwrite(&i, sizeof(int), 1, f)) != NULL) { fclose(f); return s; } i = Vec_pool_size; if ((s = xfwrite(&i, sizeof(int), 1, f)) != NULL) { fclose(f); return s; } if ( (s = xfwrite(&Free_list, sizeof(cell), 1, f)) != NULL || (s = xfwrite(&Free_vecs, sizeof(cell), 1, f)) != NULL || (s = xfwrite(&Symbols, sizeof(cell), 1, f)) != NULL ) { fclose(f); return s; } i = 0; v = Image_vars; while (v[i]) { if ((s = xfwrite(v[i], sizeof(cell), 1, f)) != NULL) { fclose(f); return s; } i++; } if ( fwrite(Car, 1, Cons_pool_size*sizeof(cell), f) != Cons_pool_size*sizeof(cell) || fwrite(Cdr, 1, Cons_pool_size*sizeof(cell), f) != Cons_pool_size*sizeof(cell) || fwrite(Tag, 1, Cons_pool_size, f) != Cons_pool_size || fwrite(Vectors, 1, Vec_pool_size*sizeof(cell), f) != Vec_pool_size*sizeof(cell) ) { fclose(f); return "image dump failed"; } fclose(f); return NULL; } static char *xfread(void *buf, int siz, int n, FILE *f) { if (fread(buf, siz, n, f) != n) { return "image file read error"; } return NULL; } char *s9_load_image(char *path, char *magic) { FILE *f; cell n, **v; int i; struct magic m; int image_nodes, image_vcells; char *s; f = fopen(path, "rb"); if (f == NULL) return "could not open file"; if ((s = xfread(&m, sizeof(m), 1, f)) != NULL) return s; if (memcmp(m.id, magic, 2)) { fclose(f); return "magic match failed"; } if (memcmp(m.version, S9_VERSION, sizeof(m.version))) { fclose(f); return "wrong image version"; } if (m.cell_size[0]-'0' != sizeof(cell)) { fclose(f); return "wrong cell size"; } if (m.mantissa_size[0]-'0' != S9_MANTISSA_SEGMENTS) { fclose(f); return "wrong mantissa size"; } memcpy(&n, m.byte_order, sizeof(cell)); #ifdef BITS_PER_WORD_64 if (n != 0x3132333435363738L) { #else if (n != 0x31323334L) { #endif fclose(f); return "wrong byte order"; } memcpy(&n, m.prim_slots, sizeof(cell)); if (n != Last_prim) { fclose(f); return "wrong number of primitives"; } memset(Tag, 0, Cons_pool_size); if ((s = xfread(&image_nodes, sizeof(int), 1, f)) != NULL) return s; if ((s = xfread(&image_vcells, sizeof(int), 1, f)) != NULL) return s; while (image_nodes > Cons_pool_size) { if ( Node_limit && Cons_pool_size + Cons_segment_size > Node_limit ) { fclose(f); return "image cons pool too large"; } new_cons_segment(); } while (image_vcells > Vec_pool_size) { if ( Vector_limit && Vec_pool_size + Vec_segment_size > Vector_limit ) { fclose(f); return "image vector pool too large"; } new_vec_segment(); } if ( (s = xfread(&Free_list, sizeof(cell), 1, f)) != NULL || (s = xfread(&Free_vecs, sizeof(cell), 1, f)) != NULL || (s = xfread(&Symbols, sizeof(cell), 1, f)) != NULL ) { fclose(f); return s; } v = Image_vars; i = 0; while (v[i]) { if ((s = xfread(v[i], sizeof(cell), 1, f)) != NULL) return s; i++; } if ( (fread(Car, 1, image_nodes*sizeof(cell), f) != image_nodes*sizeof(cell) || fread(Cdr, 1, image_nodes*sizeof(cell), f) != image_nodes*sizeof(cell) || fread(Tag, 1, image_nodes, f) != image_nodes || fread(Vectors, 1, image_vcells*sizeof(cell), f) != image_vcells*sizeof(cell) || fgetc(f) != EOF) ) { fclose(f); return "wrong file size"; } fclose(f); return NULL; } /* * Initialization */ void s9_exponent_chars(char *s) { Exponent_chars = s; } void s9_image_vars(cell **v) { Image_vars = v; } void s9_add_image_vars(cell **v) { int i, n, m; cell **nv; if (Image_vars != NULL) { for (n=0; Image_vars[n] != NULL; n++) ; for (m=0; v[m] != NULL; m++) ; nv = malloc((n+m+1) * sizeof(cell *)); if (nv == NULL) s9_fatal("add_image_vars(): out of memory"); n = 0; for (i = 0; Image_vars[i] != NULL; i++) nv[n++] = Image_vars[i]; for (i = 0; v[i] != NULL; i++) nv[n++] = v[i]; nv[n] = NULL; v = nv; } Image_vars = v; } static void resetpools(void) { Cons_segment_size = S9_INITIAL_SEGMENT_SIZE; Vec_segment_size = S9_INITIAL_SEGMENT_SIZE; Cons_pool_size = 0, Vec_pool_size = 0; Car = NULL, Cdr = NULL; Tag = NULL; Free_list = NIL; Vectors = NULL; Free_vecs = 0; Primitives = NULL; Max_prims = 0; } void s9_init(cell **extroots) { int i; GC_ext_roots = extroots; for (i=2; iname, "cons")) error("prim_info()"); if (!function_p(new_atom(T_FUNCTION, NIL))) error("function_p()"); n = s9_make_real(1, -5, s9_make_integer(12345)); if (!real_p(n)) error("real_p()"); if (s9_real_exponent(n) != -5) error("real_exponent()"); if (s9_bignum_to_int(s9_real_mantissa(n)) != 12345) error("real_mantissa()"); n = s9_make_string("hello, world!", 13); if (!string_p(n)) error("string_p()"); if (strcmp(string(n), "hello, world!")) error("string()"); if (string_len(n) != 14) error("string_len()"); n = s9_symbol_ref("foobarbaz"); if (!symbol_p(n)) error("symbol_p()"); if (strcmp(symbol_name(n), "foobarbaz")) error("symbol_name()"); if (symbol_len(n) != 10) error("symbol_len()"); if (s9_symbol_ref("foobarbaz") != n) error("symbol_ref()"); if (!syntax_p(new_atom(T_SYNTAX, NIL))) error("syntax_p()"); n = s9_make_vector(100); vector(n)[0] = Zero; vector(n)[99] = One; if (!vector_p(n)) error("vector_p()"); if (vector(n)[0] != Zero) error("vector(0)"); if (vector(n)[99] != One) error("vector(99)"); if (vector_len(n) != 100) error("vector_len()"); if (!continuation_p(new_atom(T_CONTINUATION, NIL))) error("continuation_p()"); n = s9_make_string("foo", 3); m = s9_copy_string(n); if (strcmp(string(n), string(m))) error("copy_string()"); if (!atom_p(new_atom(0, NIL))) error("atom_p()"); n = s9_new_vec(T_STRING, 100); if (!string_p(n)) error("new_vec(1)"); if (string_len(n) != 100) error("new_vec(2)"); save(One); save(Two); if (s9_unsave(1) != Two) error("save(2)"); if (s9_unsave(1) != One) error("save(1)"); if (!constant_p(s9_cons3(NIL, NIL, S9_CONST_TAG))) error("constant_p()"); n = s9_make_primitive(&P); save(n); m = cons(NIL, NIL); if (s9_typecheck(n, m) == NULL) error("typecheck(1)"); m = cons(One, NIL); m = cons(NIL, m); m = cons(Zero, m); if (s9_typecheck(n, m) == NULL) error("typecheck(2)"); m = cons(One, NIL); m = cons(Zero, m); if (s9_typecheck(n, m) == NULL) error("typecheck(3)"); m = cons(NIL, NIL); m = cons(Zero, m); if (s9_typecheck(n, m) != NULL) error("typecheck(4)"); n = s9_apply_prim(n, m); s9_unsave(1); if (car(n) != Zero) error("apply_prim(1)"); if (cdr(n) != NIL) error("apply_prim(2)"); if (s9_find_symbol("new-symbol") != NIL) error("find_symbol(1)"); n = s9_make_symbol("new-symbol", 10); if (s9_find_symbol("new-symbol") != NIL) error("find_symbol(2)"); s9_intern_symbol(n); if (s9_find_symbol("new-symbol") == NIL) error("find_symbol(3)"); m = s9_symbol_to_string(n); if (!string_p(m) || strcmp(string(m), "new-symbol")) error("symbol_to_string()"); if (s9_string_to_symbol(m) != n) error("string_to_symbol(1)"); s9_string_to_symbol(s9_make_string("xxyyzz", 6)); if (s9_find_symbol("xxyyzz") == NIL) error("string_to_symbol(2)"); if (s9_type_tag(Zero) != S9_T_INTEGER) error("type_tag(1)"); if (s9_type_tag(s9_make_string("", 0)) != S9_T_STRING) error("type_tag(2)"); if (s9_type_tag(s9_symbol_ref("foo")) != S9_T_SYMBOL) error("type_tag(3)"); if (s9_type_tag(S9_TRUE) != S9_T_BOOLEAN) error("type_tag(4)"); if (s9_type_tag(S9_NIL) != S9_T_NONE) error("type_tag(5)"); } void test_bignum(void) { cell n; if (s9_bignum_to_int(Zero) != 0) error("Zero"); if (s9_bignum_to_int(One) != 1) error("One"); if (s9_bignum_to_int(Two) != 2) error("Two"); n = s9_make_integer(-123); if (s9_bignum_to_int(s9_bignum_abs(n)) != 123) error("bignum_abs()"); A = s9_make_integer(1235); B = s9_make_integer(5678); if (s9_bignum_to_int(s9_bignum_add(A, B)) != 6913) error("bignum_add()"); N = s9_bignum_divide(B, A); if (s9_bignum_to_int(car(N)) != 4) error("bignum_divide(1)"); if (s9_bignum_to_int(cdr(N)) != 738) error("bignum_divide(2)"); if (s9_bignum_equal_p(A, B)) error("bignum_equal_p(1)"); if (!s9_bignum_equal_p(A, A)) error("bignum_equal_p(2)"); if (s9_bignum_even_p(A)) error("bignum_even_p(1)"); if (!s9_bignum_even_p(B)) error("bignum_even_p(2)"); if (!s9_bignum_less_p(A, B)) error("bignum_less_p(1)"); if (s9_bignum_less_p(B, A)) error("bignum_less_p(2)"); if (s9_bignum_less_p(B, B)) error("bignum_less_p(3)"); N = s9_make_integer(123); if (s9_bignum_to_int(s9_bignum_multiply(N, N)) != 15129) error("bignum_multiply()"); if (s9_bignum_to_int(s9_bignum_negate(A)) != -1235) error("bignum_negate()"); N = s9_bignum_shift_left(N, 7); if (s9_bignum_to_int(N) != 1237) error("bignum_shift_left()"); N = s9_bignum_shift_right(A); if (s9_bignum_to_int(car(N)) != 123) error("bignum_shift_right(1)"); if (s9_bignum_to_int(cdr(N)) != 5) error("bignum_shift_right(2)"); if (s9_bignum_to_int(s9_bignum_subtract(A, B)) != -4443) error("bignum_subtract()"); N = s9_bignum_to_string(A); if (!string_p(N) || strcmp(string(N), "1235")) error("bignum_to_string()"); } cell mant(cell x) { return s9_bignum_to_int(s9_real_mantissa(x)); } cell result(cell r, cell xe, cell xm) { int m = mant(r); return xe == s9_real_exponent(r) && m == xm; } void test_real(void) { if (!real_p(Epsilon)) error("Epsilon"); N = s9_make_real(1, 2, s9_make_integer(314)); if (Real_exponent(N) != 2) error("Real_exponent()"); A = s9_bignum_to_int(new_atom(T_INTEGER, Real_mantissa(N))); if (A != 314) error("Real_mantissa()"); if (Real_negative_flag(N)) error("Real_negative_flag()"); if (Real_zero_p(N)) error("Real_zero_p()"); if (!Real_positive_p(N)) error("Real_positive_p()"); if (Real_negative_p(N)) error("Real_negative_p(1)"); N = Real_negate(N); if (!Real_negative_p(N)) error("Real_negative_p(2)"); A = s9_make_real(1, 1, s9_make_integer(123)); B = s9_make_real(-1, -1, s9_make_integer(456)); if (s9_real_negative_p(s9_real_abs(B))) error("real_abs()"); N = s9_real_add(A, B); if (!result(N, -1, 11844)) error("real_add()"); N = s9_real_divide(A, Two); if (!result(N, 0, 615)) error("real_divide()"); if (s9_real_equal_p(A, B)) error("real_equal_p(1)"); if (!s9_real_equal_p(A, A)) error("real_equal_p(2)"); N = s9_real_floor(B); if (!result(N, 0, -46)) error("real_floor()"); N = s9_real_trunc(B); if (!result(N, 0, -45)) error("real_floor()"); N = s9_real_ceil(B); if (!result(N, 0, -45)) error("real_ceil()"); if (!s9_real_integer_p(A)) error("real_integer_p(1)"); if (s9_real_integer_p(B)) error("real_integer_p(2)"); if (s9_real_less_p(A, B)) error("real_less_p(1)"); if (!s9_real_less_p(B, A)) error("real_less_p(1)"); if (s9_real_less_p(B, B)) error("real_less_p(2)"); N = s9_real_multiply(B, Two); if (!result(N, -1, -912)) error("real_multiply()"); N = s9_real_negate(B); if (!result(N, -1, 456)) error("real_negate()"); if (s9_real_zero_p(N)) error("real_zero_p()"); if (!s9_real_positive_p(N)) error("real_positive_p()"); if (s9_real_negative_p(N)) error("real_negative_p(1)"); N = s9_real_negate(N); if (!s9_real_negative_p(N)) error("real_negative_p(2)"); N = s9_real_subtract(A, B); if (!result(N, -1, 12756)) error("real_subtract()"); N = s9_real_to_bignum(A); if (s9_bignum_to_int(N) != 1230) error("real_to_bignum()"); N = s9_real_multiply(Ten, Ten); N = s9_real_sqrt(N); if (!s9_real_equal_p(N, Ten)) error("real_sqrt(1)"); N = s9_make_real(1, -2, s9_make_integer(256)); N = s9_real_sqrt(N); A = s9_make_real(1, -1, s9_make_integer(16)); if (!s9_real_equal_p(N, A)) error("real_sqrt(2)"); N = s9_real_power(Two, Ten); if (!s9_real_equal_p(N, s9_make_integer(1024))) error("real_power(1)"); N = s9_real_power(Two, s9_real_negate(Two)); A = s9_make_real(1, -2, s9_make_integer(25)); if (!s9_real_equal_p(N, A)) error("real_power(2)"); A = s9_real_sqrt(Two); B = s9_make_real(1, -1, s9_make_integer(5)); B = s9_real_power(Two, B); if (!s9_real_equal_p(A, B)) error("real_power(3)"); } void print_test(char *name, void (*printer)(cell), cell n, char *s) { int p, op, i; char b[100]; p = s9_open_output_port(TESTFILE, 0); op = s9_output_port(); s9_set_output_port(p); (*printer)(n); s9_close_port(p); s9_set_output_port(op); p = s9_open_input_port(TESTFILE); op = s9_input_port(); s9_set_input_port(p); i = s9_blockread(b, 100); if (i > 0) b[i] = 0; s9_close_port(p); s9_set_input_port(op); if (strcmp(s, b)) error(name); } void test_io(void) { int c, i, p; char b[100]; if (s9_input_port() != 0) error("input_port(1)"); if (s9_output_port() != 1) error("output_port(1)"); p = s9_open_output_port(TESTFILE, 0); s9_set_output_port(p); s9_prints("0123456789"); s9_close_port(p); s9_reset_std_ports(); p = s9_open_input_port(TESTFILE); s9_set_input_port(p); for (i=0; i<5; i++) { if ((c = s9_readc()) != "0123456789"[i]) error("readc(1)"); } s9_rejectc(c); for (i=4; i<10; i++) { if ((c = s9_readc()) != "0123456789"[i]) error("readc(2)"); } s9_close_port(p); s9_reset_std_ports(); p = s9_open_output_port(TESTFILE, 1); s9_set_output_port(p); s9_prints("0123456789"); s9_close_port(p); s9_reset_std_ports(); p = s9_open_input_port(TESTFILE); s9_set_input_port(p); if (s9_blockread(b, 20) < 20) error("blockread()"); s9_close_port(p); s9_reset_std_ports(); if (s9_input_port() != 0) error("input_port(2)"); if (s9_output_port() != 1) error("output_port(2)"); print_test("print_bignum()", s9_print_bignum, s9_string_to_bignum("-12345678901234567890"), "-12345678901234567890"); print_test("print_expanded_real()", s9_print_expanded_real, s9_make_real(1, -6, s9_make_integer(12345)), "0.012345"); print_test("print_sci_real()", s9_print_sci_real, s9_make_real(1, -6, s9_make_integer(12345)), "1.2345e-2"); for (i=0; i ("" "" ""). (ext/csv) Added CSV:READ and CSV:WRITE help pages. (help/csv/) 2017-01-24 Added CSV (comma-separated values) extension containing CSV:READ and CSV:WRITE primitives. (ext/csv/) 2016-12-06 Fix: S9SOS mis-computed the precedence order for multi-methods. Patch supplied by David Person, thank you! 2016-11-30 Upgrade to S9core Mk III. (s9core.*) s9_make_integer() will now return pre-allocated objects for some common values (0, 1, 2, 10). (Thanks, David Person!) Added type_tag() accessor. 2016-08-23 The LENGTH fix of 2014-12-06 got reverted somewhere along the way. Re-fixed. (s9.c) 2016-08-05 Upgrade to S9core Mk II. (s9.c, s9*.h) Added -e (eval) and -r (run) command line arguments. (s9.c) 2015-11-19 real_ceil(), real_floor(), real_trunc() could fail when being passed an integer. Thanks, Alexander Shendi! (s9core.c) 2015-11-17 Added real_power() function to s9core, added EXPT primitive (unused, though; the Scheme version is faster). (s9core.[ch]) 2015-11-08 S9core: added the open_input_string(), close_input_string(), and port_eof() functions. (s9core.[ch]) S9core: fixed some function types (mostly port-related), made readc() and reject() functions (previously macros). (s9core.[ch]) Updated the S9core manual. (s9core.tr) Fixed a potential GC leak in string_to_bignum(). (s9core.c) 2015-08-10 Fix: S9core: make_vector() overwrote unallocated memory. (s9core.c) (This bug did *not* affect the S9 interpreter!) 2015-07-14 Made APROPOS find extension procedures. (contrib/) 2015-07-13 Adapted S9HELP to the new help folder structure. (prog/) Renamed extension directories to reflect their names: ext/unix --> ext/sys-unix, ext/plan9 --> ext/sys-plan9. Modified install scripts for new help structure. 2015-07-12 Renamed NETWORK extension to NET-UNIX. (ext/unix/) Moved portable procedures from ext/ to lib/. Re-structured help folder: moved extension procedures to separate directories. (help/) Made HELP find only procedures of extensions that are actually available. (contrib/) 2015-07-09 Added add_image_vars() function to S9core. (s9core.*) Cleaned up S9 bignum <-> C int conversion. (ext/plan9/) Fixed some bugs in sys_convD2M(). (ext/plan9/) Added DIR structure to Plan 9 extension. (ext/plan9/) 2015-07-07 Imported Bakul Shah's Plan 9 extension. (ext/plan9/) Cool! Thanks! Restructured the extensions directory: * ext/ -- portable extensions (might even move to lib/) * ext/unix, ext/plan9 -- OS-specific extensions * ext/curses -- curses extension 2015-07-06 Fix: internal counters did not count trillions correctly. (s9core.c) Thanks, Arun Srinivasan! 2015-07-01 Changed Plan 9 install procedure to allow for multi-platform installation. (mkfile, util/) Added *HOST-SYSTEM* to help pages. (help/) 2015-06-30 Added install target for Plan 9. (mkfile) Fix: embedded newline in a string literal would not bump the line counter. (s9.c) Thanks, David Person! 2015-06-29 Added *HOST-SYSTEM* variable. (s9.c) Made HELP print without prompting on Plan 9. (contrib/) Added Plan 9 installation procedure. 2015-06-28 Rewrote signal handling to use notify()/noted() on Plan 9. (s9.c) ------------------------------------------------------------------------------- Interface change: S9core PRINT is now called PRINTS; see below. ------------------------------------------------------------------------------- 2015-06-27 Renamed print() function of S9core to prints(). Sorry about the inconvenience; "print" is reserved in the Plan 9 C library. Fixed some Plan 9 issues (signal handlers, function declarations, mkfile). (s9.c, s9core.c) C2HTML: fixed missing after keyword at end of file. (contrib/) 2015-06-23 Removed TRACE help page and entry in *S9FES-PROCEDURES*. Fix: added MACRO-EXPAND and MACRO-EXPAND-1 (had been removed accidentally). (s9.c) Thanks, nullbuilt0! (reddit) 2015-06-18 Fix: (expt 0 r) ==> 0 for r > 0. (s9.scm) Added regression tests. (util/) 2015-06-17 Fix: Added missing POSIX/XOPEN prelude to Unix extension (required on Linux, Cygwin, etc). (ext/) 2015-06-15b Extended magic ID length to 16 bytes. (S9core) Included time stamp in magic ID. (s9.c) Fixed (expt 0 r) where r is not integer. (s9.scm) 2015-06-15 General: - Factored out the S9core, providing a library for implementing dynamic languages. Discussed in s9core.pdf. - Real number arithmetics are now a non-optional part of the interpreter. Policy changes: - Images are preferred over source files on startup, i.e. first all directories of *LIBRARY-PATH* are searched for images, then all directories are searched for source files. The old policy was to load the first image /or/ source from the first directory containing either of those. - Existing output files are silently overwritten by the OPEN-OUTPUT-FILE, WITH-OUTPUT-TO-FILE, and WITH-OUTPUT-FILE functions. Previous policy was to signal an error. - The S9:S9 procedure will be called last when initializing extensions thereby allowing it to call procedures of other extensions. (Previously, S9:S9 was called first.) Additions: - The *ARGUMENTS* variable binds to a list of strings containing the command line arguments passed to the /program/ (not to the interpreter), i.e. the ARGS in "-f program args". Command line options: - The -f flag is now optional, i.e. "s9 -f file args" and "s9 file args" do the same. - The "-m size" flag has been split into "-k size" (vectors) and "-n size" (nodes). - "-u" is short for "-k 0 -n 0" (unlimited space). - "-n" no longer means "do not load rc file". Removals: - S9 no longer loads an rc file (~/.s9fes/rc) on startup. Use the image file and the (badly documented) S9:S9 procedure to do things on start-up. - Dropped the "-t count" command line option. The five most recently called procedures will print in error messages. - Dropped "imprecise" digits ("#") from number format. Use "5" instead, that's what it did anyway. - Dropped the TRACE command. - Dropped the DUMP-IMAGE procedure. (Use -d) ------------------------------------------------------------------------------- S9core Refactoring ------------------------------------------------------------------------------- 2015-06-08 Fix: (lambda (x) ...) and (define (x) ...) would attempt to macro-expand (x). Thanks, David Person! Note: this still fails in (cond (x)). Rename X as a work-around. 2015-03-31 Added statistics functions: CDF, ERF, MEAN, MEDIAN, MODE, NDF, QUARTILE, RANGE, STDDEV, VARIANCE. (lib/) 2015-03-13 Added constants (S_zero, ...) for frequently used bignum literals, so we don't have to call make_integer() each time. (s9.c, s9-real.c) 2015-03-12 Fix: TRACE without arguments could core-dump on some machines. (s9.c) Thanks, David Person! Made real number division round its mantissa instead of truncating it, e.g.: (/ 2 3) --> 0.66...67 instead of 0.66...66. Should improve real number precision a bit. (s9-real.c) Suggested by David. 2015-03-10 Fix: These functions would not terminate for certain values due to inappropriate real number comparison: EXP, LOG, COS, SIN, TAN, ATAN, SQRT. Thanks to David Person for pointing this out! (s9-real.scm) Introduced *EPSILON* constant representing the least real number with a precise representation. (s9.c) 2014-12-16 Simplified print_symbol() procedure. (s9.c) 2014-12-13 Fixed ATAN function for negative arguments. (s9-real.scm) Thanks again, David! Added some #ifdefs to guess whether we are compiling on a 64-bit system. (s9.h) 2014-12-06 Fix: LENGTH would print garbage when reporting an improper list. (s9.c) Thanks, David Person! 2014-11-26 Added new Plan 9 mkfile and straightened out the build process on non-Unix systems. Thanks, Ray Lai! 2014-11-25 Modified util/libtest.sh to not include the Unix extension tests when the Unix extension is not present. 2014-11-24 Fix: replaced atol() with internal version to work around Plan 9 atol()'s behavior (leading '0' means octal). (s9.c, s9-real.c) 2014-11-05 Fixed SPAWN-COMMAND help page. (ext/, help/) 2014-11-03 Fixed some warnings in util/rpp.c (not used outside of build). 2014-10-31 Fixed a few potential GC leaks. (s9.c, s9-real.c) 2014-08-08 Changed hash function. (s9.c) 2014-08-04 Fix: wrong magic number in 64-bit image check. (s9.c) 2014-08-03 Missing help link: REAL? (help/, util/) 2014-07-25 Fix: MAKE-MATCHER accidentally redefined CASE using an equivalent but less efficient version. (lib/) 2014-07-21 Simplified LET* (s9.scm) 2014-07-18 Made LENGTH and LIST-TAIL use integers internally. (s9.c) 2014-07-17 Made the fatal error handler print "fatal " to stderr when running in batch mode. (s9.c) 2014-07-16 Added the "99 bottles" example (using SYNTAX-RULES). (contrib/) 2014-07-12 Fix: STRING->SYMBOL, SYMBOL->STRING, STRING-APPEND and STRING-COPY work on counted strings now. (s9.c) Fixed embarassing crash when reporting type errors, introduced four days ago when changing the primitive procedure representation. (s9.c) 2014-07-11 Applied some small cosmetical fixes. (s9.c) 2014-07-10 Renamed symbols beginning with an underscore for increased portability. (s9.c, s9.h, s9-real.c) 2014-07-09 Removed binary ID from magic header, added number of primitives instead. (s9.c) 2014-07-08 Made the reader report the location where an delimited list started. (s9.c) Invented a new method for storing primitive procedures in images in a way that cooperates well with ASLR and PIC. (s9.c) 2014-06-29 Made APROPOS (and ,a) return _all_ procedures, even those not currently loaded. (contrib/) Patch from http://github.com/barak/scheme9: intercept file read errors when reading an image file. Thanks, Barak! (s9.c) Added and documented EVAL procedure. (s9.c) 2014-06-27 Made EDOC source code a better example of EDOC. (prog/edoc.scm.edoc) 2014-06-25 Removed S9E, the S9 Editor, because it was broken. (contrib/) 2014-05-30 Fixed some bogus warnings generated by Clang. 2014-01-11 Added clarifying coment in lookup(). (s9.c) Fixed typo in man page. Thanks, Yi Dai (s9.1) 2013-11-26 Added ARGV primitive to core system. See below. (s9.c) 2013-11-24 Added ENVIRON and SYSTEM primitives to the core interpreter. (s9.c) Mostly to use minimal S9 in web programming. 2013-04-10 Added a workaround for plan9's atol() function, which interprets leading '0' as octal. Thanks, Bakul Shah! (s9.c) 2013-02-09 Fix: FORMAT-TIME emitted wrong month name with ~@m. Thanks, Doug Currie! (ext/) 2013-01-22 Fix: S9E would abort when exiting from the [^L][e] prompt using backspace. (contrib/) 2013-01-17 Added COLLECT procedure. (lib/) 2013-01-14 Fix: SYNTAX-RULES could abort while matching an ellipsis against an atom. (lib/) 2013-01-09 S9E: Fixed highlighting of marked regions in side-scrolled lines. (contrib/) 2013-01-02 Added experimental "hard" cutting (TRY/CUT) to AMK. (lib/) Added the N-Queens program (using AMK). (contrib/) 2012-12-26 Added numeric goals to AMK. (lib/) 2012-12-22 More changes to AMK for compatibility with the upcoming version of the book. (lib/) 2012-12-20 Made AMK always return () or (()) when no variable was given in RUN*. (lib/) 2012-12-17 Added color customization to S9E. (contrib/) 2012-12-12 Cleaned up AMK, made it more compatible with the book. (lib/) Fix: REM-PROP reversed its property list argument. (lib/) 2012-12-10 Finished S9E, the new S9 Editor with integrated REPL buffer. (contrib/) 2012-12-05 Made DEFINE-MACRO an alias of DEFINE-SYNTAX. (s9.c) 2012-12-02 Fix: GENSYM had a potential race condition resulting in a wrong prefix. (s9.c) Checked for similar race conditions due to string/vector pool compaction; seems clean. 2012-11-30 Fix: SUBSTRING had a GC race condition, which could result in the extraction of garbage. (s9.c) 2012-11-27 Added SRFI-43-compliant VECTOR-COPY and VECTOR-APPEND primitives. (s9.c, s9.scm) 2012-11-26 Fix: REM-PROP failed to remove properties from empty lists. (lib/) Removed SYS:LCHOWN and SYS:LUTIMES system calls. Caused only portability issues. (ext/) 2012-11-25 Added S9SYMBOLS program (dump symbols from help pages). (prog/) 2012-11-24 Added "-i -" (don't load heap image) option. (s9.c) 2012-11-18 Added color support to GET-LINE. (ext/) Added more key codes to GET-LINE. (ext/) 2012-11-15 Added CURS:KEY-DC (delete-char key), CURS:KEY-IC (insert-char key), and CURS:KEY-END constants. (ext/) 2012-11-14 Fix: swapped fore/background arguments of CURS:COLOR-SET. (ext/) 2012-11-13 Fix: PACKAGE was lacking an import of FILTER. (lib/) Fix: test process created wrong image file. (util/) Thanks, Doug Currie! 2012-11-12 Added color support to the curses extension. (ext/) Added the CURS:COLOR-SET and CURS:HAS-COLORS primitives. (ext/) Updated the help pages. 2012-11-11 Simplified creation of top-level bindings. (s9.c, s9.h) Removed SYNTAX? predicate. (s9.c) Added -P (prolog) and -E (epilog) options to EDOC. (prog/) Changed web color scheme. (util/) 2012-11-09 Factored out CHAR-PLOT from RUNTIME-STATS. (ext/, lib/) Made CHAR-CANVAS a package. (lib/) Made RUNTIME-STATS a package. (ext/) 2012-11-08 Made IOTA accept a second argument. (lib/) Added the CHOOSE procedure. (lib/) Added the CURRYR (curry-right) macro. (lib/) 2012-11-07 Made GENSYM accept a symbolic argument. (s9.c) 2012-11-04 Added extra LDFLAGS for OSX. Thanks, Doug Currie! Fix: (lambda x ...) did not work in SYNTAX-RULES. (lib/) 2012-11-02 Fixed a potential memory leak in SYS:EXECVE. (ext/) Made (the still broken) SYNTAX-RULES alpha-rename variables of named LET and DO. (lib/) 2012-11-01 Added LIST-COPY and TAKE procedures. (lib/) Renamed GROUP-LIST to GROUP, swapped arguments to be more consistent with other list procedures. (lib/) Reverted EQUAL? to comparing vectors by converting them to lists first. (s9.c) 2012-10-30 Renamed QUEUE and UNQUEUE to QUEUE! and UNQUEUE!. (lib/) Updated help pages. Cleaned up cooperative threads procedures and fixed last thread exit problem. (lib/) Made the interpreter reset the TTY when exiting after an error. (s9.c) Added more EQUAL? tests. (util/) 2012-10-27 Added a SIGTERM handler to reset the TTY when curses support is compiled in. (s9.c) 2012-10-22 Optimized DRAW-TREE. (contrib/) 2012-10-21 Cleaned up DRAW-TREE code. (contrib/) 2012-10-19 Fixed order of assignment in FLUID-LET. (lib/) 2012-10-17 Made IOTA a single-argument procedure. (lib/) Renamed IMPORT keyword of simple-modules to USING. (lib/) 2012-10-16 Fix: SCM2HTML did not reset color after comments in quoted objects in string-input mode. (s9.c) 2012-10-14 Suppressed trailing blanks when stopping run-away output. (s9.c) Fixes bounds checking in multi-dimensional ARRAYs. (lib/) 2012-10-13 Fix: NUMBER->STRING would suppress trailing zeroes in expanded real numbers. E.g.: (number->string 1.23e5) ==> "123". Oops! (s9-real.scm) 2012-10-11 Made SCM2HTML accept upper case # syntax, e.g.: #F. (contrib/) 2012-10-11 Made BIT-OP variadic. (s9.c) Added BIT-OP operations 16 (shift left) and 17 (shift right). (s9.c) 2012-10-10 Made EQUAL? cons-free when comparing vectors. (s9.scm) 2012-10-09 Made the reader and printer abort processing of suspiciously deeply nested lists and vectors. Thanks to dig1 and bsamograd on reddit! (s9.c, s9.h) Made EDOC generate back links only in level-0 headings. (prog/) 2012-10-05 Now accepting [...] as an alias of (...). (s9.c) Updated SCM2HTML to handle [...] properly. (contrib/) Updated test suite. (util/) Fix: STANDARD-ERROR-PORT was documented as STANDARD-ERROR. (help/) 2012-10-04 Fix: error reporting was broken by interruptible printer. (s9.c) 2012-10-03 Made WRITE and DISPLAY primitives interruptible. (s9.c) Passed help files through spell-checker. (lib/, contrib/, prog/, help/, edoc/) 2012-10-02 Added "variable index" command to EDOC. (prog/) Added REAL type to TYPE-OF and TYPE-CASE. (lib/) 2012-09-29 Added "non-printing index" command to EDOC. (prog/) 2012-09-25 Added "unreadable" syntax (#) to SCM2HTML. (contrib/) 2012-09-24 Fixed quotation in SCM2HTML. (contrib/) Added -t (tilde-quotes) flag to SCM2HTML1. (prog/) 2012-09-22 Added style for invisibly quoted forms to SCM2HTML. (contrib) 2012-09-21 Added the TILDE-QUOTES option to SCM2HTML. (contrib/) Made EDOC pass 'TILDE-QUOTES: #T to SCM2HTML. (prog/) 2012-07-09 Changed webdump color scheme. (util/) Adapted web theme to current home page. (util/) Updated the man page. (s9.1) Misc. cosmetical changes. (lib/) 2012-07-08 Renamed SOS to S9SOS - S9 Simple Object System. (contrib/) Replaced the '!image' option by '-i image'. (s9.c) Allowed to specify an image source file with '-i'; made the LIBRARY option obsolete. (s9.c) Cleaned up some meta files. 2012-07-06 Fixed more typos. 2012-07-05 Removed the ARSE development environment, because it has a design bug that makes it crash when undoing changes near the top or bottom of a file. Fixed a few typos. Fix: BIT-OP could overflow on 64-bit systems. (s9.c) 2011-05-11 Cleaned up the Unix/POSIX/XOPEN Mambo Jambo prelude. (s9.h) Added some casts to make later GCCs happy. (s9.c, s9-real.c) (unreleased.) 2010-11-13 Fix: sudden allocation of large vector failed, even if enough vector space was present (this did not happen when allocating lots of small vectors, releasing them, and then allocating a large vector). (s9.c) 2010-10-29 Fix: missing hash-table reference in memoize.scm. (lib/) 2010-10-11 Added GET-PROP, PUT-PROP, etc. (lib/) 2010-10-08 Added STRING-PREFIX=? and STRING-PREFIX-CI=? procedures. (lib/) 2010-10-07 Fix: MAKE-STRING and MAKE-VECTOR did not check for negative arguments. (s9.c) 2010-10-06 Added TIME-ADD, TIME-SUBTRACT, TIME-DIFFERENCE, TIME-BEFORE?, and TIME-AFTER? procedures. (lib/) Moved SWAP! to "setters.scm"; removed "swapb.scm". (lib/) 2010-10-05 Added small-magnitude bit operators (bitops). (lib/) 2010-10-04 Renamed BITWISE-AND-NOT --> BITWISE-NOT-AND, BITWISE-OR-NOT --> BITWISE-NOT-OR, BITWISE-XOR-NOT --> BITWISE-NOT-XOR. (lib/) Added fast bit operations (BIT-OP). (s9.c) 2010-10-03 Misc. minor changes. This is the book version. 2010-09-29 Applied minor change to RIB internal structure. (s9.c) 2010-09-27 Added \i (image) mode to EDOC. (prog/) 2010-09-23 Added "NIL" and "@ rest" syntax to MAKE-MATCHER. (lib/) 2010-09-22 Added line concatenation via \\ to EDOC, made EDOC's -b option link to a file given on the command line instead of hardwiring "index.html". (prog/) 2010-09-21 Changed MAKE-MATCHER semantics. Once again. :-/ But this time it will be final! (lib/) Moved the MAKE-MATCHER code to the EDOC section. (lib/, edoc/) 2010-09-19 Re-organized the "primitives" section. (s9.c) 2010-09-16 Moved SYNTAX-RULES to EDOC section. (lib/, edoc/) 2010-09-13 EDOC: Improved layout of Lout output; still experimental, though! (prog/) 2010-09-11 Fixed some minor 64-bit/prototyping glitches. (s9*.c) 2010-09-10 Added HTMLIFY-CHAR and LOUTIFY-CHAR to library. (lib/) Started Lout backend in EDOC. (prog/) 2010-09-09 EDOC: improved error messages, implemented strict mode (being picky about matching braces). (prog/) 2010-09-07 Fixed botched optimization in EXP function. (s9-real.scm) 2010-09-06 Cleaned up real number primitives. (s9-real.c) 2010-09-05 DISPLAY/WRITE now round the last digit of real numbers with large mantissas, so 1.99999999999999997 actually prints as 2.0 on 32-bit systems. (s9-real.scm) Added INC!, DEC!, and SET-VARS! syntax. (lib/) 2010-09-04 Factored out CHECK-BINDINGS and SPLIT-BINDINGS in the Scheme core. (s9.scm) Fix: a quotation char ('`,) followed by a closing paren swallowed that closing paren. (s9.c) 2010-09-03 Fix: APPEND accepted atoms in positions other than the last. (s9.scm) PRETTY-PRINT now prints (and), (or), and (begin) more nicely. (contrib/) 2010-09-02 Allowed nested quasiquotation as long as an embedded QUASIQUOTE is inside of UNQUOTE or UNQUOTE-SPLICING. (s9.scm) Applied more optimizations to MAKE-MATCHER. (lib/) Added GROUP-LIST procedure to library. (lib/) Fix: WITH-OUTPUT-TO-FILE always returned #. (s9.scm) 2010-09-01 Made STRING and VECTOR primitives. (s9.c) Fix: SYS:READLINK did not NUL-terminate its return string. (ext/) Optimized internal accessors of MAKE-MATCHER. (lib/) 2010-08-31 Changed PACKAGE syntax and semantics. (lib/) Added Red-Black Trees. (lib/) Various small changes. (s9.c) 2010-08-29 Changed MAKE-MATCHER syntax. (lib/) Retired ML-MATCH syntax. (lib/) 2010-08-26 Applied various cosmetics and micro-optimizations. (s9.c) 2010-08-25 Changed environment box model from (name . (value)) to (name . value), (ab?)using the CDR field as a box. This saves quite a few conses during evaluation. (s9.c) Improved syntax checking in local DEFINEs. (s9.c) Added detection of improper lists (syntax errors) in special forms. (s9.c) 2010-08-24 Made STATS primitive expand macros before evaluation. (s9.c) 2010-08-22 Fix: Made EXPT return an inexact number when passed an inexact argument, because conversion lost digits. Also made SQRT return an inexact result. (s9-real.scm) 2010-08-20 Documented EDOC using EDOC. (prog/) Fix: counting newlines in block comments. (s9.c) 2010-08-19 SCM2HTML: added support for block comments. (s9.c) 2010-08-15 Fix: all real numbers must be inexact according to R4RS. (s9.c) Fixed a precision bug in mixed bignum/real operations. (s9-real.c) Fixed missing trailing zero in (number->string 1.0). (s9-real.scm) 2010-08-14 Cleaned up SCM2HTML program. (contrib/) Added C2HTML program. (contrib/) 2010-08-13 Changed interface of SCM2HTML and moved it to contrib/. Added SCM2HTML1 program (SCM2HTML wrapper). (prog/) Fix: (+ 0.0 -1.0e-999999999) gave 0.0. (s9-real.c) Fix: (+ #e0.0 #e1.0e-999999999) gave an inexact result. (s9-real.c) 2010-08-12 ARSE: made [d][/]x and [d][?]x repeatable. (contrib/) Added ,q (sys:exit) meta command. (s9.c) Added #| ... |# comments. (s9.c) 2010-08-10 Tweaked real number interface (internal). (s9*.[ch]) Updated the man page. (s9.1) 2010-08-09 Finished integration of big real number support. (*.c, *.scm) 2010-08-08 Re-integrated big real arithmetics. (*.[ch], *.scm) Added real number test suite. (util/) 2010-08-07 Added make-cats.scm program and CATEGORIES.html file. (util/) 2010-08-06 ARSE: fix: clear undo log when loading a different file into an edit buffer. (contrib/) 2010-08-03 Fix: (,x) was interpreted as a meta command. (s9.c) Fix: SYNTAX-RULES failed to detect some syntax errors before ellipses. (lib/) S9 SOS: make instantiation invalid. (contrib/) Added 'COMPRESS: option to RUNTIME-STATS. (ext/) 2010-08-02 Applied some cosmetics to SYNTAX-RULES. (lib/) Added LISTQ syntax. (lib/) Made APPEND fold to the right (O(n) instead of (O(n^c) when appending multiple lists). (s9.scm) Added COLS program. (prog/) 2010-08-01 CHAR-CANVAS: auto-clipping out-of-range coordinates. (lib/) RUNTIME-STATS: misc. small fixes. (ext/) 2010-07-31 Added plotter and table formatter to RUNTIME-STATS. (ext/) Fixed CANVAS-PLOT-LINE. (lib/) 2010-07-30 Added the RUNTIME-STATS procedure to library. (ext/) Added SWAP! syntax to library. (lib/) Added character-based canvas to library. (lib/) 2010-07-29 Made STATS return a list instead of printing its data. (s9.c) Added SYS:GETTIMEOFDAY extension procedure. (ext/) Added TIME procedure to library. (/ext) Fixed S9 SOS built-in hierarchy. (contrib/) 2010-07-28 Added meta commands, which are entered by typing a #\, at the top level and without any enclosing parens. See S9(1) for details. (s9.c) 2010-07-27 Added PUSH! and POP! macros. (lib/) Added PACKAGE macro. (lib/) 2010-07-26 Removed UNDEFINED primitive; causes only trouble. (s9.c) Added minor optimizations to MAKE-MATCHER. (lib/) Made MAKE-MATCHER and ML-MATCH two separate packages. (lib/) 2010-07-25 Made S9 not count initial GC in STATS. (s9.c) Added cons cell statistics to interpreter. (s9.c) Fix: SYNTAX-RULES failed to expand stuff following "...". (lib/) 2010-07-24 Added TREE-MAP procedure. (lib/) Fix: RE-MATCH returned wrong format when processing REs beginning with "^" in combination with 'ALL. (lib/) 2010-07-23 Finished the S9 SOS and its documentation. (contrib/) 2010-07-21 Made ":set regex" default in ARSE. (contrib/) 2010-07-20 Bootstrapped SOS. (contrib/) 2010-07-19 ARSE: removing output that begins with ";" when reloading a buffer. (lib/) 2010-07-18 Added first sketch of SOS (Scheme Object System). (contrib/) Added 'REVERSE keyword to T-SORT; added T-SORT-NET. (lib/) Added 'TOP-DOWN option to T-SORT. (lib/) ARSE: added "scheme-init" option. (contrib/) 2010-07-17 Added 'CONVERT-UNREADABLE option to READ-FROM-STRING. (lib/) Added help pages for the REVERSE!, STATS, SYNTAX?, TRACE, VOID, and UNDEFINED procedures. (help/) 2010-07-16 Added UNDEFINED procedure; see s9(1). (s9.c) 2010-07-15 Added KEYWORD-VALUE procedure. (lib/) Rewrote HASH-TABLE, added support for 'SIZE and 'TEST keywords. (lib/) Added WHEN, UNLESS, WHILE, and UNTIL syntax. (lib/) ARSE: made [TAB] insert blanks when not typing a symbol. (contrib/) 2010-07-14 Added DUPLICATES procedure and friends. (lib/) DEFINE-STRUCTURE not reports duplicate slot names. (lib/) 2010-07-13 Added queue data type. (lib/) 2010-07-12 Added MEMOIZE procedure and DEFINE-MEMOIZED syntax. (lib/) 2010-07-11 Added ID (identity) procedure. (lib/) ARSE: added regex support to [/] and [?] commands. (contrib/) Re-organized library. (lib/) Added check-descr.scm to check descriptions for web dump. (util/) 2010-07-10 Added SPLIT and MERGE procedures, rewrote MERGESORT. (lib/) Fixed stuck state (0) in RANDOM-STATE. (lib/) Fix: SYS:MAKE-INPUT-PORT and SYS:MAKE-OUTPUT-PORT could return a closed port due to GC. (ext/) Rewrote BITWISE-... operators. (lib/) Added INTEGER->BINARY-STRING and BINARY-STRING->INTEGER. (lib/) Fix: RE-SUBST generated wrong matches with trailing "\\)". (lib/) 2010-07-09 ARSE: fixed spurious trailing lines after undo. (contrib/) ARSE: added regular expression support (:s). (contrib/) Added COMPOSE, COMPLEMENT, TRUE, and FALSE procedures. (lib/) Added RANDOM and RANDOM-STATE procedures. (lib/) 2010-07-08 Added SYNTAX? primitive. (s9.c) Added T-SORT (topological sort) procedure. (lib/) Added EQUAL-CI? procedure. (lib/) Added TYPE-OF procedure and TYPE-CASE syntax. (lib/) Added ASSP and MEMP procedures. (lib/) Applied various small fixes to PRETTY-PRINT. (contrib/) Updated man page. (s9.1) 2010-07-07 Added RE-SUBST procedure to REGEX package. (lib/) Added TREE-COPY procedure. (lib/) 2010-07-06 Added auto-completion to ARSE. (contrib/) Added ADJOIN, SET-DIFFERENCE, and SUBSET? procedures. (contrib/) Added -COPY procedure to DEFINE-STRUCTURE. (lib/) Replaced lots of REVERSEs with REVERSE!. (*) 2010-07-05 Added POSITION and friends to library. (lib/) ARSE: fixed tab expansion; added "unexpand" option. (contrib/) 2010-07-04 Added the AMB (backtracking) operator. (lib/) Added HASH-TABLE-REMOVE! and ALIST->HASH-TABLE; renamed HASH-TABLE->LIST to HASH-TABLE->ALIST. (lib/) Fix: (cond ('(()))) was an error. (s9.c) 2010-07-03 Fix: FOR-ALL sometimes returned #T unexpectedly. (lib/) Fix: CALL/CC could crash AND, BEGIN, COND, and OR. :-/ (s9.c) Added ARRAY-MAP procedure. (lib/) 2010-07-02 Added more array operations. (lib/) 2010-07-01 Added Common LISP-style CATCH/THROW. (lib/) Added ARRAYs and array operations. (lib/) 2010-06-30 Renamed DEFINE-RECORD to DEFINE-STRUCTURE, allowed simpler slot syntax. (lib/) 2010-06-29 ARSE: reload main buffer automatically when recovering from a REPL error. (s9.c) ARSE: fix: undo delete lines at end of buffer. (contrib/) 2010-06-28 Renamed EXPAND-MACRO to MACRO-EXPAND (more CL'ish). (s9.c) Added MACRO-EXPAND-1 procedure. (s9.c) Added Common LISP TAGBODY to library. (lib/) 2010-06-27 Added CALL-WITH-CURRENT-CONTINUATION (CALL/CC). (s9.c) Related critical change in s9.c:_eval(): name = car(rib_source(rib)); - /* Save result */ - car(Stack) = Acc; if (Trace_list != NIL) Imported CALL/CC description from R4RS. (help/) Added LET/CC to library. (lib/) Added cooperative thread functions. (lib/) Removed CALL-WITH-ESCAPE-CONTINUATION. 2010-06-26 Added REVERSE! primitive and used in some places. (s9.c, s9.scm) Made (re-match (re-comp "^") "foo") ==> ((0 0)) and (re-match (re-comp "$") "foo") ==> ((3 3)). (lib/) Added 'ALL option to RE-MATCH. (lib/) Added VECTOR-MAP, made VECTOR-MAP! variadic. (lib/) Added STRING-MAP and STRING-MAP!. (lib/) 2010-06-25 Made S9 ignore SIGPIPE, so the SYS: procedures can catch broken pipe conditions themselves. (ext/) ARSE: ignore broken pipe condition when writing to REPL. (contrib/) ARSE: added autocenter option. (contrib/) Cleaned up the REGEX procedures and added submatches. (lib/) Made RE-MATCH return ranges rather than strings. (lib/) 2010-06-24 Misc. clean-up. 2010-06-23 Factored out all the S9fES stuff in ARSE, so it can be ported to other Schemes more easily. (contrib/) ARSE: [r] did not check autoindent option. (contrib/) Added ARSE porting instructions. (contrib/) Added VECTOR-MAP! and STRING-SCAN procedures. (lib/) ARSE: expanding tabs to spaces when reading filters, etc. (contrib/) 2010-06-22 Added DEFINE-RECORD syntax. (lib/) (DEFINE-SYNTAX (F ...) ) accepted only a single-expression body. Fixed that. (s9.c) ARSE: no longer displaying the REPL buffer when reloading or recompiling. (contrib/) ARSE: some general clean-up. (contrib/) 2010-06-21 Finished Unix extension test suite. (util/) Documented SYS:SLEEP, SYS:USLEEP. (help/) 2010-06-20 SYS:CHOWN did not work. (ext/) ARSE: :s//... did not allow leading blanks in . (contrib/) ARSE: missing REAL-POS! in SUBSTITUTE and COLON-READ. (contrib/) Added SYS:SLEEP, SYS:USLEEP procedures. (ext/) 2010-06-19 Removed SYS:LCHMOD; not portable. (ext/) Cleaned up symlinks in help directory. (help/) 2010-06-18 Fix: hash tables did not allow negative numeric keys. (lib/) 2010-06-17 Added a quick and dirty dependency checking mode to S9RESOLVE. (prog/) Fixed some unresolved library dependencies. ;-) * Explanation: * The default image file contains most of the S9fES library * functions, so it does not really need all those LOAD-FROM-LIBRARY * calls. However, I consider it to be good style to make library * dependencies explicit by adding them anyway. S9RESOLVE -d detects * missing LOAD-FROM-LIBRARYs. 2010-06-16 Factored out FIND-HELP-PATH procedure. (ext/) Added SPAWN-SHELL-COMMAND procedure. (ext/) SPAWN-COMMAND has new semantics, SPAWN-SHELL-COMMAND implements the old behavior. (ext/) Added more missing symlinks to help directory. (help/) 2010-06-14 Added the SYS:FILENO procedure. (ext/) Fix: SYS:SELECT sometimes returned #F even when some descriptors were ready. (ext/) Fix: PP-FILE could not find LINEFEED procedure. (contrib/) Made the pretty-printer indent embedded IF, COND, etc in code mode rather than data mode. (contrib/) 2010-06-13 Removed CURS:KEY-EOL from curses, because it is not the key labeled "END" on a PC keyboard. Which KEY_ constant is used for this key? My /usr/include/curses.h says KEY_SELECT, but this does not appear to make sense. (ext/) 2010-06-12 Made READ-FROM-STRING skip over comments in multi-line input. (contrib/) Added SYS:CATCH-ERRORS and SYS:STRERROR primitives. (ext/) Made SPAWN-COMMAND redirect stderr of the spawned command to stdout so it can be read by the parent. (ext/) Added URL-DECODE procedure to library. (lib/) 2010-06-11 Added the PP-STRING procedure to the pretty-printer. (contrib/) 2010-06-10 Added the INET-SERVER procedure to the extension library. (ext/) Rewrote S9HTS using INET-SERVER. (prog/) Reinstalled and fixed a load of wrong or missing symlinks in help directory. (help/) 2010-06-09 Added the SPLIT-URL procedure to the library. (lib/) 2010-06-08 Added SYS:INET-GETPEERNAME primitive to Unix extension. (ext/) Implemented S9HTS, a simple HTTP server. (prog/) Added STRING-POSITION and friends to library. (lib/) Added STRING-LAST-POSITION and friends to library. (lib/) 2010-06-06 Added the CURSES_RESET compile time option, which will run CURS:ENDWIN automatically in the REPL, so Curses cannot hose the interface in interactive sessions. Of course, when using this option, (CURS:INITSCR) will not have any effect when entered at the REPL. (s9.c) Moved ARSE (was: SCHED) to contrib/, kept only the command line interface in prog/. Added ARSE installation procedure to Makefile. Documented ! option. (s9.1) Fix: not all globals were initialized in PRETTY-PRINT. (contrib/) Fix: PP printed a lonely closing paren in intended applications with no arguments. (contrib/) 2010-06-05 Added !image option to change the heap image name ad hoc. (s9.c) 2010-06-02 Fixed a few bugs in ADVGEN; it only worked due to the below bug in S9. :-/ 2010-06-01 Fix: Local environments of *dynamically* scoped (a.k.a. top-level) procedures were still being propagated to functions called *iff* there were multiple levels of local definitions in the top-level procedure, e.g.: (define (g) x) (define (f) (let ((x 0)) (let () ; <-- this triggered the bug (g) #f))) (f) ==> 0 ; should be an error (x undefined) This is definitely fixed now. Regression test added. (s9.c) 2010-05-31 Intercepted more funny characters. (s9.c) 2010-05-30 Made STRING->NUMBER accept base prefixes. (s9.scm) Replaced some applications of the obsolete WRONG procedure with applications of ERROR. (s9.scm) Made the interpreter identify funny input characters. (s9.c) 2010-05-28 Fixed a GC bug introduced by growing the pools independently. This bug was triggered by using more vector space than node space. (s9.c) Improved the stress test suite. (util/) 2010-05-27 ADVGEN: renamed GO/RET to GO/SEL. (prog/) Tweaked the sample adventure. (prog/) 2010-05-26 S9 now takes its image name from argv[0] instead of hardwiring it. (s9.[ch]) Added new FORMAT help page with better explanations and lots of examples; try (help 'format). (help/) 2010-05-25 Fix: FORMAT recursed indefinitely in case of an error due to re-use of the name ERROR. (contrib/) 2010-05-24 Added expansion template to AND-LET* description. (lib/) Added Curses interface help pages. (help/) Added CURS:LINES and CURS:COLS procedures. (ext/) Fix: MAKE-STRING did not type-check second argument. (s9.c) 2010-05-23 Added first version of a CURSES(3) interface. (ext/) Fixed GC bug in APPEND2. Made cons and vector pools grow independently. (s9.c) 2010-05-22 Stopped interpreter from reporting infinite sequences of '(' in error messages, even if the reported structure is cyclic. Added AND-LET*. (lib/) Minor cosmetics. 2010-05-21 Improved limited output in error messages. (s9.c) Running "make tests" will now use a minimum heap image, so unresolved references in the library will be detected. (Makefile) Improved ADVGEN error messages. (prog/) Added COPY-FROM special description to ADVGEN. (prog/) 2010-05-20 Made DEFINE-SYNTAX an alias for DEFINE-MACRO; removed DEFINE-MACRO. (s9.c) Moved SYNTAX-RULES to the extension library. (lib/) Added the STANDARD-ERROR-PORT, WITH-OUTPUT-TO-STDERR, and CALL-WITH-STDERR procedures. (ext/) Limited size of Scheme objects in error messages. (s9.c) Updated S9(1) man page and help pages. (help/) Various small fixes and cosmetics. 2010-05-19 Added GO/RET operator to ADVGEN. (prog/) Applied various minor improvements to the pretty-printer. (contrib/) Added default values to PARSE-OPTIONS!. (ext/) Added SCMPP pretty-print utility. (prog/) Added more features to ADVGEN; see prog/advgen.txt. 2010-05-18 Fixed a long-standing bug that caused the following program to evaluate to 1: (define (g) x) (define (f) (let ((x 1)) (g) #f)) (f) This happened only if (g) was *not* a tail call. The critical part of the fix is: + if (!tail && cdr(Environment) != NIL) + Environment = cdr(Environment); in s9.c:bind_arguments(). 2010-05-17 Added ADVGEN documentation, fixed some minor bugs. (prog/) 2010-05-16 Added GO/CUT operator to ADVGEN. (prog/) Added STRING-FIND-LAST, STRING-FIND-LAST-WORD, STRING-CI-FIND-LAST, STRING-CI-FIND-LAST-WORD. (lib/) Fix: SCM2HTML did no longer accept input from stdin. (prog/) Fix: SCM2HTML rendered #[bdox] literals in wrong color. (prog/) Fix: ADVGEN: stupid bug in HTML postlude. (prog/) Fix: SCM2HTML: #\$ is a valid symbol character. (prog/) Added missing symlinks to help database. (help/) 2010-05-15 Documented NAME->FILE-NAME. (contrib/) Added code to install utility programs. (Makefile) Added COUNTER option type and "--" special argument to PARSE-OPTIONS!. (ext/) Added ADD/GO and REM/GO actions to ADVGEN. (prog/) 2010-05-14 Added new option types to PARSE-OPTIONS!. (ext/) 2010-05-13 Added STRING-TRANSLATE procedure to library. (lib/) Finished sample ADVGEN adventure. (prog/) Fixed a bug in PARSE-OPTIONS!: option args were always taken from first option. Oops. (lib/) 2010-05-12 Fixed names in error messages of CAAR..CDDDDR. (s9.c) Implemented first version of ADVGEN, an HTML adventure generator. (prog/) 2010-05-11 Made email addresses in the code harder to harvest. 2010-05-10 Added HTMLIFY utility. (prog/) Added stuff for automatic web site creation. (util/) 2010-05-09 Renamed all UNIX:... symbols to SYS:... and made naming more consistent. All names in the SYS-UNIX extension now begin with SYS:. (ext/) Moved SYS:FLUSH with no args to library (FLUSH-OUTPUT-PORT). (ext/) Added LETREC* syntax. (lib/) 2010-05-08 While I am at it: made these procedures primitives: APPEND, LIST-TAIL, MIN, MAX. (s9.c, s9.scm) Fixed READ-FROM-STRING (mixed up some numbers and symbols). (lib/) Added #B, #D, #O, #X prefixes to READ-FROM-STRING. (lib/) Renamed STRING-FIND to STRING-LOCATE and STRING-CONTAINS to STRING-FIND. Also swapped the arguments of STRING-FIND so that STRING-FIND and STRING-LOCATE are more consistent now. (lib/, contrib/) Added [+-][st] modifiers to CHANGE-MODE. (ext/unix.scm) 2010-05-07 Made these procedures primitives: ABS, ASSQ, ASSV, CAAR..CDDDDR, EQV?, EVEN?, LENGTH, LIST, MEMQ, MEMV, NEGATIVE?, NOT, NULL?, ODD?, POSITIVE?, REVERSE, ZERO?. Resulting speed increase is between 30% (libtest) and 70% (htmlize library). (s9.c, s9.scm) Added -9 (highlight non-R4RS symbols) and -x (highlight extensions) arguments to SCM2HTML utility. (prog/) Added indentation of DO. (contrib/pretty-print.scm) Fixed evluation of DO in PROGRAM?: allowed more than one statement in body, made statement in termination clause optional. (lib/programp.scm) 2010-05-06 Made DRAW-TREE print more compact trees by emitting the conses of (...(x)...) as soon as possible. (contrib/draw-tree.scm) Added interactive mode to SOCCAT program. (prog/) Added UNIX:ACCESS help page. 2010-05-05 Added purely functional streams to library. (lib/streams.scm) Added UNIX:WAITPID procedure. Fixed type checking in UNIX:KILL (accepted single argument). Added the SOCCAT utility. (prog/soccat) 2010-05-04 Added UNIX:SELECT procedure. 2010-05-03 Made argument of FLUSH optional (defaults to current output port). Added UNIX:INET-CONNECT, UNIX:INET-LISTEN, and UNIX:INET-ACCEPT procedures. Made UNIX:* procedures print more informative error messages. Added mode argument to UNIX:MKDIR, made it optional in MKDIR. 2010-05-02 Made UNIX:STAT not follow symlinks. Added STRING-CONTAINS-WORD and STRING-CI-CONTAINS-WORD. (lib/) Added FIND-HELP procedure. (ext/) Made PARSE-OPTIONS! accept symbolic options (instead of strings). 2010-05-01 Added UNIX:SETUID, UNIX:SETGID. UNIX:GETPGID, UNIX:SETPGID. Added DISPLAY*. (lib/) 2010-04-30 Added the UNIX:FORK, UNIX:WAIT, and UNIX:EXECV procedures. Added the UNIX:ACCESS and SEARCH-PATH procedures. (ext/) Replaced the primitive UNIX:SPAWN and SPAWN procedures with the high-level SPAWN-COMMAND procedure. (ext/spawn-command.scm) Added S9RESOLVE program, which resolves S9fES library dependencies. (prog/) Hash tables sizes now adapt automatically. (lib/hash-table.scm) 2010-04-29 Added more Unix procedures: UNIX:CLOSE, UNIX:CREAT, UNIX:DUP, UNIX:DUP2, UNIX:LSEEK, UNIX:MAKE-INPUT-PORT, UNIX:MAKE-OUTPUT-PORT, UNIX:OPEN, UNIX:PIPE, UNIX:READ, UNIX:WRITE, UNIX:UMASK. Also added the APPEND-TO-OUTPUT-FILE procedure. (ext/) 2010-04-28 Added PARSE-OPTIONS! and friends. (ext/parse-options.scm) Installing contribs directly in @S9DIR@ now. Made UNIX:READDIR skip the "." and ".." entries. Added UNIX:RENAME procedure. 2010-04-27 Added the STRING-UNSPLIT procedure (lib/). Made HASH-TABLE-REF return just a value (lib/hash-table.scm). Error messages are now printed on stderr when the interpreter runs in quiet mode (-q). Added DIRNAME procedure. Moved contrib/pretty-print.scm to prog/scm2html.scm and made it a stand-alone program. Moved S9 configuration from Makefile to config.scm. 2010-04-26 Added help pages for all remaining UNIX: procedures. Added the STAT-type? predicates for finding out the type of a directory entry. Added the BASENAME procedure. Removed the S9U(1) man page, because it basically duplicates the help pages. Added "programs" section (prog/) and dupes program. 2010-04-25 Added "pattern=mode" to UNIX:CHMOD. Added some UNIX: procecures to the help database. Added STRING-PARSE procedure. Made STRING-SPLIT generate empty strings when multiple subsequent separators are found. Updated S9U(1) man page (was S9E(1) man page). Updated help pages. 2010-04-24 Merged S9 and S9E interpreters; configure in Makefile. Added third return value (PID) to UNIX:SPAWN. Added UNIX:KILL and KILL procedures. Added R4RS test cases to test suite. 2010-04-23 Removed real number stuff. Removed Scientific Calculator stuff. Removed statistics package. ------------------------------------------------------------------------------- Forked this version. ------------------------------------------------------------------------------- 2009-09-06 Removed EXPAND-QUASIQUOTE. It is no longer needed, because EXPAND-MACRO can now be used to expand quasiquoted forms. Documented the interpreter start-up process in the man page. Renamed WRONG to ERROR to make it more compatible with SRFI-23 error reporting. 2009-09-05 Rewrote QUASIQUOTE as a macro and removed all quasiquotation functionality from the C part. 2009-09-03 Included "./lib" and "./contrib" in DEFAULT_LIBRARY_PATH, so S9 can load libraries after just compiling it in its build directory. Added the S9:S9 start-up hook. When a nullary procedure named S9:S9 exists, it will be called when S9 starts. Added the DUMP-IMAGE primitive, which allows to write a new heap image from the REPL. Updated the help pages. 2009-09-02 Made SQRT return an exact value whenever possible. 2009-08-14 Fix: '() printed two ()'s (was introduced with #). Added the UNSORT procedure to LIB. 2009-08-11 Fixes: - Cleaned up the SC extension; - Added missing S9SC(1) man page. Thanks again, Masaru KIMURA. 2009-08-08 Added constants for options, so you can write (plot* -7 7 sin type: scatter style: 3) instead of (plot* -7 7 sin 'type: 'scatter 'style: 3). 2009-08-07 Added 'X-GRID: and 'Y-GRID: options to S9SC SETUP procedure. Added abbreviations, e.g.: 'STEP: for 'X-STEP: and 'Y-STEP:, etc. Fix: second argument of EXPT could not be real. 2009-08-06 Added option argument checking to S9SC procedures. Fix: made PRINT-CODE generate proper links for LOAD-FROM-LIBRARY arguments without ".scm" suffix. 2009-08-05 Wrote the S9SC(1) man page. 2009-08-04 Re-organized the extension libraries. Renamed the GFX extension to SC. Added initialization procedures to extensions. Made (LOG N) return # for non-positive N. 2009-07-26 Fixed some warnings in GFX extension. Thanks, Barak Pearlmutter. 2009-07-25 Added statistics package to CONTRIB. Added the Scheme 9 Scientific Calculator extension (S9SC). Note that S9SC is *very* experimental at this stage. 2009-07-08 Fixed that rounding bug in ATAN. 2009-07-05 Test suite failed on 64-bit machines due strange rounding errors in ATAN. Decreased accuracy to 4 digits as a lame work-around. Suggestions welcome. 2009-07-04 Added support for unspecific digits (#) to STRING->NUMBER. Fix: (ASIN 1) and (ACOS 0) were undefined. Fixed some minor flaws. Added tests for ACOS, ASIN, ATAN, and STRING->NUMBER. 2009-07-01 Added the ACOS, ASIN, ATAN procedures. Fix: real number normalization *first* removed trailing zeros and *then* truncated the mantissa. Oops. 2009-06-29 Added '#' syntax for unspecific digits in inexact numbers. 2009-06-26 Fix: STRING->NUMBER always returned an inexact result for real number representations. 2009-06-25 Fix: Stack was not cleaned up properly in some error conditions. Fix: (*) and (+) could crash the interpreter. Internal: Added 64-bit emulation for 32-bit systems. 2009-06-15 Minor cleanup, added comments where necessary. * Do not expect any updates in the near future. * I need a break from programming. * Bug reports are still welcome, but will get low * priority for now. 2009-06-09 Fixed a variable collision in the hash table implementation. (lib/hash-table.scm) 2009-06-08 Made PRINT-CODE recognize new numeric functions as primitives. Fixed INVERSEO procedure in AMK. 2009-06-07 Made STRING->NUMBER recognize real numbers. Fix: missing initialization of got_d in string_numeric(). Fix: FLOOR and EXACT->INEXACT did not normalize their results. Simplified counter_to_string(), based on code by Masaru KIMURA. Added loads of tests for STRING->NUMBER. 2009-06-06 Extended domain of NUMBER->STRING to REAL. Added support for the "precision markers" D,F,L,S, although only one floating point precision exists. Fix: MANTISSA did not return negative signs. Fix: INEXACT->EXACT lost the sign of its operand. Fix: #I created a double sign in negative integers. Added/updated help pages for various procedures. Added more tests. 2009-06-05 Fix: SIN, COS, TAN expected degrees, should be radians. Oops. Ran further 64-bit tests on the Alpha, all passed. 2009-06-04 Implemented LOG and EXP procedures. Added tests. Fixed size of Called_procedures[]. Good catch, Masaru KIMURA. 2009-06-03 Implemented CEILING, FLOOR, ROUND, TRUNCATE procedures. Implemented SIN, COS, and TAN procedures. Added tests for all of the above. Made procedures expecting integers accept real numbers too, as long as they are exact and can be converted to integer without loss of precision. Added tests. Made the reader accept an excess number of digits in the mantissa, giving an inexact number. 2009-06-02 * I have tested this release on my Alpha with -DBITS_PER_WORD_64 * and it passed all tests. If make test still fails on Linux/PPC, * I would need SSH access to a PPC box to investigate further. Implemented SQRT. Fixed INTEGER? (mistook random objects for integers). Removed some 64-bit glitches. Applied some cosmetics. Added test cases. 2009-06-01 Implemented real number division (/). Made INTEGER? return #T for reals that can be converted to integer without loss of precision. Made INEXACT->EXACT return an integer whenever possible. Extended domain of EXPT to real. Implemented the internal EXPONENT and MANTISSA procedures. Fixed a GC leak in real_normalize(). Thanks, Masaru KIMURA. Added test cases for / and EXPT. Added more type test cases. Updated the S9(1) man page. 2009-05-31 Implemented real number multiplication (*). Just try: (expt 9.9 999999999). Is this cool? Intercepted numeric underflow and overflow. Added test cases for real *. Added #E and #I syntax. Added real number test cases for #E, #I, EXACT->INEXACT, INEXACT->EXACT, NEGATIVE?, POSITIVE?, ZERO?. 2009-05-30 Fixed INEXACT->EXACT (sign error). Implemented real -. Implemented exactness in - the +, MIN, and MAX procedures; - bignum-->real conversion; - real number normalization. Added real number tests for -, ABS, MIN, MAX. Added test cases for EXACT->INEXACT and INEXACT->EXACT. 2009-05-29 Implementated real +. Implemented EXACT? and INEXACT?. Implemented EXACT->INEXACT and INEXACT->EXACT. Fixed a few bugs in real <. Added real number tests for +. 2009-05-28 Added more test cases for real <. Extended domains of <=, >, >= to real. Added real number tests for <=, >, and >=. * Please stress-test the real number routines * and do report errors! * Suggestions for additional tests are welcome! 2009-05-27 Added mantissa size to magic ID of image files. Implemented comparison of real numbers in <. Added real number tests for <. 2009-05-26 Moved sign of reals to flags field in order to allow for -0.0. Changed flat_copy() so that it can copy special atoms, too. Added real number tests for =. Cleanup. 2009-05-25 Added a reader and printer for real numbers. Implemented internal representation for real numbers. Implemented comparison of real numbers in =. Added more syntax tests to test suite (primarily in order to test the real number reader and printer). Added REAL? predicate. Made NUMBER? an alias of REAL?. Applied some minor cosmetics. * Note that you cannot yet do anything really useful with * real numbers other than translating them from/to external * representation and comparing them. 2009-05-24 Added code to detect real number syntax and dispatch it to a specialized reader. Yes, this is a first step toward real number arithmetics, but don't hold your breath right now. 2009-05-23 Improved the documentation of the matcher package. Removed unused list_of_symbols() function from "s9.c". Thanks, Masaru KIMURA (also for misc. other cosmetics). 2009-05-22 Moved "define-match.scm" to "matcher.scm". Renamed DEFINE-MATCH to DEFINE-MATCHER, added LET-MATCHER syntax to matcher package. Extended matchers so that 'SYMBOL matches a literal symbol. (lib/matcher.scm) Improved rendering of (cond (p => x)) in pretty printer. (contrib/pretty-print.scm) Applied various cosmetics. 2009-05-21 Added STRING-UPCASE and STRING-DOWNCASE procedures. (lib/string-case.scm) 2009-05-20 Simplified HASH-TABLE procedures. (lib/hash-table.scm) 2009-05-17 Included help pages for ALL procedures of the extension library! Just try (load-from-library "draw-tree") and then (help 'draw-tree). LOAD-FROM-LIBRARY now attaches a ".scm" suffix, if the given file cannot be located, i.e., you can write (load-from-library "foo") instead of (... "foo.scm"). Tweaked the image dump/load routines. Fixed a (self-made) bug in FORMAT (~A would slashify output). 2009-05-16 Fix: made strings returned by SYMBOL->STRING immutable. Updated the help pages. Prepared comments in library files for automatic generation of help pages. (Stay tuned.) 2009-05-14 Added code to grow the memory pools when loading large images. Added interpreter tag to magic header (images are not portable). Added another tweak for POSIX compatibility. 2009-05-13 Administrative: - Removed all those special variables ($@, $<, ...) from Makefile, because some(?) of them are simply not portable. - Added -Dunix to compilation of unix.c (sic!). 2009-05-12 Applied some cosmetics to s9.scm. Administrative: fixed local environment in the build process. 2009-05-11 Fix: PRINT-CODE handled QUOTE inside of QUASIQUOTE incorrectly. (contrib/print-code.scm) Fixed a bug that resulted in multiple evaluation of DELAYed expressions. 2009-05-10 Minor fix: protected car(x) in syntax_object_p(). Cosmetics. Changed allocation strategy. We will now use half of the memory pool at most. OK, this gives us the same space efficiency as a copying collector, but with the advantage of having cons objects in fixed places on the heap. The performance gain is about 35% (zebra puzzle). 2009-05-09 Minor fix: protected argument in pp_load(). Made conceptual difference between string and symbol names [string() vs. symbol_name(), string_len() vs. symbol_len()]. Removed clone_string() due to above separation. Using O(1) string_len() instead of O(n) strlen() in pp_gensym(). Checking length first in STRING=? and STRING-CI=?. 2009-05-07 Fix: PRINT-CODE generated tag soup when two subsequent tokens were to be printed in boldface. Added another tweak for Unix portability to s9.h. 2009-05-06 Administrative change: - #ifdef __unix and #ifdef unix are obviously insufficient to check for a Unix system; added -Dunix to Makefile. Thanks, Barak Pearlmutter! 2009-05-05 Administrative changes: - Applied some fixes to the build process. - Created browsable version of the library code. - Added version tag (timestamp) to distribution file. - Added deinstall target to Makefile. 2009-05-04 Replaced '| by ': in ML-style syntax of DEFINE-MATCH, because '| is not portable. Removed MAP-CAR from documentation, because it is only used internally. Simplified definition of LETREC (cosmetics). Made the code printer generate links to files included via LOAD-FROM-LIBRARY. (contrib/print-code.scm) 2009-05-03 Added a pattern matcher with optional support for ML syntax to the library. (lib/define-match.scm) Updated the test suite. Moved the online help system to contrib. (contrib/help.scm) Moved DRAW-TREE to contrib. (contrib/draw-tree.scm) Included the pretty-printer and the online help system in the default heap image. 2009-05-01 Fixed some 64-bit flaws. Many thanks to Torsten Leibold for giving his AlphaStation 200 4/233 to me! 2009-04-29 Fix: alpha-conversion of recursive SYNTAX-RULES was broken, leading to potentially non-hygienic expansion. Added SYNTAX-RULES version of FLUID-LET. (lib/fluid-let-sr.scm) Fix: line numbers were off after LOAD. Moved interactive programs to CONTRIB, even if they have been contributed by myself. (pretty-print.scm, print-code.scm) 2009-04-28 Finished the new and vastly improved pretty-printer. (lib/pretty-print.scm) 2009-04-27 Fixed some bugs in PROGRAM? (DO with multi-expr test part was not allowed; commands were not optional). Started rewriting the pretty-printer. 2009-04-26 Reporting file name in messages when using "-f program" option. Made the pretty-printer print '`, and ,@ instead of QUOTE, QUASIQUOTE, UNQUOTE, and UNQUOTE-SPLICING. Still more clean-up. 2009-04-25 Even more code clean-up. 2009-04-23 Applied more cosmetics. 2009-04-22 Improved hashing of lists. (lib/hash-table.scm) Added memoization to PROLOG interpreter. (contrib/prolog.scm) 2009-04-21 Applied various micro optimizations and cosmetics. Added == (unify) and DIF goals to PROLOG example. 2009-04-20 Made the interpreter print file and line number information in error messages when LOADing a file. Reverted to previous version of the PROLOG interpreter due to unclear semantics. 2009-04-19 Extended the PROLOG interpreter. (contrib/prolog.scm) 2009-04-18 Added PROLOG interpreter to contrib section. (contrib/prolog*) 2009-04-15 Fixed some error messages; made messages more uniform. Fixed a bug in the reader: the (malformed) expression (')) gave a strange result. It is an error now. 2009-04-12 Documented the VOID procedure. 2009-04-10 Added numeric base prefixes #B, #D, #O, and #X. 2009-04-09 Fix: STRING-FILL! and VECTOR-FILL! should not be able to mutate string and vector literals, either. 2009-04-08 Added the STATS primitive, which evaluates an expression and then prints some interesting data gathered during evaluation. Added the VOID procedure, which evaluates to an unspecific value. 2009-04-03 Fix: a #F literal following an ellipsis in DEFINE-SYNTAX/SYNTAX-RULES would be substituted by mistake. 2009-03-30 A Debian package was created by Barak Pearlmutter. Thanks for the package and a few minor but useful patches! 2009-03-22 Made pair, string, and vector literals immutable, so expressions like these no longer work: (set-car! '(a b) 'c) (set-cdr! '(a b) 'c) (string-set! "foo" 0 #\g) (vector-set! '#(a b) 0 'c) 2009-03-15 Added code to make S9fES compile with PCC. Wow, PCC is so much faster, still generates good code, and comes with a liberal license. Bye, bye, GCC. 2009-03-14 Added FreeBSD port. Updated s9(1) man page. 2009-03-13 Fix: made quasiquotation of improper lists work. Fix: rewrote the high-level syntax matcher and expander. DEFINE-SYNTAX and SYNTAX-RULES should work as expected now, including multiple ellipses, etc. Made the interpreter report nested QUASIQUOTE (which is currently unsupported). Added UNIX:UNLINK primitive to extended interpreter. (ext/unix.c) 2009-03-12 Made unix extension procedures return #F in case of an error instead of just aborting evaluation. Added UNIX:ERRNO primitive to extended interpreter. (ext/unix.c) Updated README, fixed s9e(1) man page, updated the binary for the unmentionable horror. 2009-03-11 Added UNIX:READDIR and UNUX:READLINK primitives to extended interpreter. (ext/unix.c) Added UNIX:GETPWENT primitive to extended interpreter. (ext/unix.c) 2009-03-10 Added FORMAT-TIME procedure to the system extension. (ext/system.scm) Updated s9e(1) man page. 2009-03-09 Added UNIX-TIME->TIME and TIME->UNIX-TIME procedures to the system extension. (ext/system.scm) 2009-03-08 Fix: removed recursion from GC of vectors. The garbage collector runs completely in constant space now. Yay! 2009-03-03 Made CHOWN accept user names and default values. (ext/system.scm) 2009-03-02 Added UNIX:GETGRNAM and UNIX:GETGRGID primitives to Unix extensions. (ext/unix.c) Added bitwise logic operations to library: BITWISE-CLEAR, BITWISE-AND, BITWISE-AND-C2, BITWISE-1, BITWISE-AND-C1, BITWISE-2, BITWISE-XOR, BITWISE-OR, BITWISE-OR-NOT, BITWISE-XOR-NOT, BITWISE-C2, BITWISE-OR-C2, BITWISE-C1, BITWISE-OR-C1, BITWISE-AND-NOT, BITWISE-SET, BITWISE-SHIFT-LEFT, BITWISE-SHIFT-RIGHT. (lib/bitwise-ops.scm) Made CHMOD accept symbolic and octal modes. (ext/system.scm) Made argument of EXIT optional. (ext/system.scm) 2009-03-01 Made the interpreter abort earlier in case of an error. Added hash table procedures to library. (lib/hash-table.scm) 2009-02-28 Added support for radixes from 2 to 36 to NUMBER->STRING and STRING->NUMBER. Not R4RS, but nice and trivial to implement. Added READ-FILE procedure to library. (lib/read-file.scm) Added STRING-FIND (fast string search) procedure to contrib. (contrib/string-find.scm) 2009-02-27 The code printer now supports vectors. (lib/print-code.scm) New: added contrib directory containing code by other authors. Added Common Lisp-style FORMAT to contrib section. Thanks, Dirk Lutzebäck. (contrib/format.*) 2009-02-26 Fix: the interpreter now accepts newline characters in string literals. Fixed quotation of strings in the WRITE-TO-STRING library procedures. Added DISPLAY-TO-STRING (lib/write-to-string.scm). 2009-02-25 Fix: test part of DO should accept multiple expressions. Added TRACE primitive. See man page for details. Fixed a bug in the PROGRAM? library function (LAMBDA should accept multiple expressions). 2009-02-22 Updated the help pages (included descriptions of dynamic top-level variables). Added the FLUID-LET syntax to the library (lib/fluid-let.scm). 2009-02-09 Updated man page and help entry for DEFINE-MACRO. 2009-02-04 Added support for named LET to the pretty-printer (lib/pretty-print.scm). 2009-02-03 Added the PROGRAM? predicate to the library (lib/programp.scm). Added automatic code/data detection to the pretty-printer (lib/pretty-print.scm). 2009-02-02 Added formatting of DO to the pretty-printer (lib/pretty-print.scm). 2009-02-01 Cleaned up installation process. Fixed vector output and quotation in the pretty-printer (lib/pretty-print.scm). 2009-01-30 Fixed indentation of lambda function applications in the pretty-printer (lib/pretty-print.scm). 2009-01-29 Allowed multiple occurrences of the -f program switch on the command line. Fixed packaging error: library files (lib/) were missing. 2009-01-28 Updated documentation. 2009-01-27 Applied some cosmetical changes (mostly s9.scm). Added some test cases for multiple expressions in bodies. 2009-01-26 Improved syntax checking of LET*. Fix: the else clause of CASE evaluated only the first expression of its body. Fix: DO now binds variables in each iteration rather than mutating them. 2009-01-25 Added the APROPOS procedure to the help system [(load-from-library "help.scm")]. Added a help page for DEFINE-MACRO. 2009-01-24 New: Finished the online help system that is based on the R4RS document. Try (load-from-library "help.scm") and then (help). Use (set! *lines-per-page* ...) to adjust the system to your preferred screen size. Improved DEFINE-SYNTAX and SYNTAX-RULES (added support for multiple ellipses per pattern). DEFINE-SYNTAX is still quirky, though. 2009-01-21 Added the -i (ignore rc file) command line option. 2009-01-20 Fix: SYMBOLS was broken by macro expansion. 2009-01-19 Added STRING-CONTAINS to the library. Factored out the LOCATE-FILE procedure, which locates a file in $S9FES_LIBRARY_PATH (s9.scm). Fixed the implementation of DELAY (it now passes all tests of Aubrey Jaffer's R4RS test suite). 2009-01-18 Added pretty-printer to the library (lib/pretty-print.scm). Added code printer to the library (lib/print-code.scm). The PRINT-CODE procedure renders Scheme code in HTML with syntax highlighting and optional CSS2-based paren matching. 2009-01-17 Added the DRAW-TREE procedure to the library. Fix: bodies of local DEFINEs may have more than one expression now. Fix: interpreter no longer breaks when attempting to expand incomplete quotation and quasiquotation. 2009-01-16 Updated manual pages. Removed FOLD-LEFT and FOLD-RIGHT from the library, because the S9fES core already contains them. Made FOLD-LEFT, FOLD-RIGHT, and map accept lists of different lengths. 2009-01-15 Added ML-style record data type to library (records.scm). Added the SYMBOLS primitive which returns a list of defined symbols. 2009-01-14 Added Another Micro Kanren (amk.scm) and the zebra example (zebra.scm) to the library. Added automatic library testing (libtest.sh). 2009-01-13 Imported the regular expression matcher of zenlisp (lib/regex.scm). Added the STRING-SPLIT, READ-FROM-STRING, AND WRITE-TO-STRING procedures to the library. Fixed DEFINE-SYNTAX: templates now may contain syntactically incorrect binding constructs. Yes, this is important; see lib/module.scm for an example. Added simple module syntax to the library (module.scm). 2009-01-12 Removed the SQRT procedure, because it always returned an integer. This procedure will be included in a future version as INTEGER-SQRT. Added the following procedures to the library of loadable functions: COMBINE, COUNT, DEPTH, EXISTS, EXPLODE, FACTOR, FACTORIAL, FILTER, FLATTEN, FOLD-LEFT, FOLD-RIGHT, FOR-ALL, HYPER, IMPLODE, INTEGER-SQRT, INTERSECTION, IOTA, LIST->SET, MAKE-PARTITIONS, MERGESORT, PARTITION, PERMUTE, QUICKSORT, READ-LINE, REMOVE, REPLACE, SUBSTITUTE, SUM, TRANSPOSE, UNION. 2009-01-11 Fixed a few more routines that relied on fixed string and vector locations and may be broken by vector pool compaction. Potentially affected: DEFINE, DEFINE-MACRO, VECTOR->LIST, STRING->LIST. 2009-01-10 I get bitten by this one over and over again. So, note to myself: C's stupid order of evaluation messes up Car[x] = alloc(foo,bar); because Car may relocate during GC. I have fixed about a dozen instances of this bug in the current version, so if you do not like nasty surprises (a.k.a. GC leaks), you may want to update. 2009-01-07 Fix: LOAD-FROM-LIBRARY did not work, because LOAD added bindings to the current local environment instead of the global environment. Loading files should be faster now, because environments are re-hashed only once per LOAD. 2009-01-06 Made s9 -v output more verbose. Added LOAD-FROM-LIBRARY procedure. Documented internal dynamic variables. 2009-01-02 Changed allocator strategy. The size of new segments grows exponentially now (n^1.5), resulting in a smaller initial memory footprint, smaller heap image, and faster adaption to memory-intensive applications. Changed default memory limit to 12.1M bytes (was 1M bytes). 2009-01-01 Cleaned up the DEFINE-SYNTAX transformer (s9.scm). Fix: the evaluator could block when running out of nodes. Added -m size (set memory limit) command line option. 2008-12-14 Applied some cosmetics. 2008-12-13 Added -g (GC summaries) command line option. 2008-12-12 Fixed missing procedure name in some error messages. 2008-12-09 The interpreter returns to the REPL now when hitting the memory limit (MEMORY_LIMIT_KN). Changed types of all references to nodes from int to cell in order to improve support for 64-bit systems. Renamed SYS extension to UNIX. 2008-12-08 A system called Scheme 9 should run on Plan 9, indeed. Thanks to Bakul Shah for pointing this out and helping me to get it ported. Thanks to Russ Cox for 9vx. 2008-11-29 Cleaned up the extension procedure interface. Adding new primitives should be a snap now. 2008-11-28 Cleaned up (internal) definitions of primitive procedures. 2008-11-26 Moved constant, variable, and macro declarations to a header file (s9.h). 2008-11-05 Fixed a subtle GC bug related to string cloning. Potentially affected: STRING-COPY, SYMBOL->STRING, STRING->SYMBOL. 2008-11-01 Fixed SYS:COMMAND-LINE (would destroy the command line when called). Cleaned up the build/install process. 2008-10-06 Fixed a bug that could crash S9 when DEFINEing variables in hashed environments. Thanks, Doug Currie. 2008-09-05 Documented the SYS extension (see s9e(1)). 2008-09-04 Applied some cosmetics to the syntax rules expander and added an example (s9.scm). 2008-09-03 Applied some cosmetical changes to the C code. Cleaned up much of the Scheme code. Included experimental SYS extension (see ext/* and EXTENSIONS in s9.c). Documented PRINT. Added else clause to COND-EXPAND. Documented COND-EXPAND. Added some macro expansion tests to the test suite. 2007-10-30 Removed SYNTAX->LIST because it is no longer needed. 2007-10-27 The interpreter is now printing a call trace in case of an error. 2007-10-23 Fix: DISPLAY can now output NUL characters. (OK, this is not really covered by R5RS, but useful, nevertheless.) 2007-10-19 Extended domain of INTEGER->CHAR to 0..255. 2007-10-17 Fix: WRITE-CHAR could not output NUL characters. 2007-10-14 Fix: interpreter core-dumped when $HOME was undefined. 2007-10-07 Fix: LOAD does not change (CURRENT-INPUT-PORT) any longer. 2007-10-06 READ now requires string literals to be contained in a single line of input. 2007-10-01 Improved error reporting in DO, LET, and LETREC. Allowed multiple expressions in bodies of CASE and improved error reporting. 2007-09-28 Removed record primitives from the interpreter, because they can be implemented portably. 2007-09-25 Removed redundant clauses from FOLD-LEFT and FOLD-RIGHT. Fixed a bug in the syntax checker of SYNTAX-RULES. ------------------------------------------------------------------------------- Major change: re-implemented DEFINE-SYNTAX/SYNTAX-RULES ------------------------------------------------------------------------------- 2007-09-23 Applied some cosmetical changes to DEFINE-SYNTAX. 2007-09-21 Added some syntax analysis and error reporting to DEFINE-SYNTAX. 2007-09-20 Added optional string argument to GENSYM. This argument is used as a prefix in generated symbols. Added an experimental implementation of DEFINE-SYNTAX and SYNTAX-RULES in terms of DEFINE-MACRO. Added header to image file format. 2007-09-14 Updated the man page. 2007-09-13 Added RECORD-TYPE-MATCHES?. 2007-09-12 Added record tests to test.scm. 2007-09-11 Added (record-copy record) => record. Added (record-signature record) => sig. Added (assert-record-type sig record) => record. 2007-09-10 Added first-class records as an experiment, including the following items: - Record syntax and external representation: #r((tag value ...)). - EQUAL? now applies RECORD-EQUAL? to pairs of records. - New procedures: - (record '(tag value) ...) => record - (record? expr) => boolean - (record->list record) => list - (list->record list) => record - (record-ref record tag) => form - (record-set! record tag value) => unspecific - (record-equal? record1 record2) => boolean 2007-09-09 Fix: SIGINT could not interrupt runaway macro expansion. 2007-09-08 Added support for extension procedures (ext/*, experimental, not yet in the distribution archive). 2007-09-04 Cleaned up the LET macro. Documented macros (S9(1)). Extended and cleaned up the test suite. 2007-09-03 Removed EXPAND-SYNTAX procedure. Added EXPAND-MACRO procedure. Added DO macro. Added heap image support for faster start-up. Added => syntax of COND. Added named LET syntax. 2007-09-02 Removed DEFINE-SYNTAX and SYNTAX-RULES. It is too cumbersome for some purposes and too complex internally. Implemented DEFINE-MACRO. Added GENSYM procedure, because it is required to write some macros. Rewrote LET, LETREC, LET*, CASE, DELAY using DEFINE-MACRO. ------------------------------------------------------------------------------- Major change: switching from DEFINE-SYNTAX to DEFINE-MACRO ------------------------------------------------------------------------------- 2007-08-29 Misc. small, cosmetical changes. 2007-08-20 Achieved a speed-up of about 10% by the use of hash chaining. Fix: heavy computations involving large lists of integers could crash the interpreter during GC. Thanks, Mario Deilmann. 2007-08-09 Made somes changes to support 64-bit architectures (not yet finished). Fixed two nasty bugs that potentially could crash the interpreter. 2007-08-06 Made OPEN-OUTPUT-PORT fail when the output file already exists. This change also affects CALL-WITH-OUTPUT-FILE and WITH-OUTPUT-TO-FILE. Added DELETE-FILE and FILE-EXISTS? procedures althouth they are not R5RS procedures, because they are simply too handy for testing file access procedures. 2007-08-05 Removed segment matches from the syntax expander, because this is not required by R5RS, so (x ... y) is not longer a valid pattern in SYNTAX-RULES. Fix: the body of COND clauses may be empty. Fix: made #\SPACE and #\NEWLINE case-insensitive. Fix: CALL-WITH-INPUT-FILE and CALL-WITH-OUTPUT-FILE did not close their ports before returning. Removed #\LINEFEED (not in R5RS). Fix: made LIST? detect cyclic structures. Removed R6RS-style comments. Made the test suite more general, so that it does not make assumptions about behavior not specified in R5RS. 2007-07-21 Fix: Syntax expansion was done after quasiquote expansion, but should have done before it. 2007-07-18 Fixed a bug in _bignum_divide(): a GC leak could occur when the divisor was greater than the dividend. 2007-07-16 Simplified test suite using DEFINE-SYNTAX. It is smaller, cleaner, and also siginificantly slower now (due to syntax transformation overhead). 2007-07-06 Applied some minor, mostly cosmetical changes to s9.c. 2007-07-04 Fix: STRING-APPEND did not check the types of its arguments. 2007-07-03 Fixed some comments, renamed some variables. 2007-07-01 Simplified read_c() and turned it into a macro. 2007-06-30 Changed representation of #, # and # from symbol to integer (optimization). Simplified atomp_p() and made it a macro. Directed all interpreter output through pr(). 2007-06-29 Fixed a bug in the syntax expander. 2007-05-26 Adding hash tables broke **. Fixed that. 2007-05-22 Added hash tables to environments for faster lookup speed. Fix: the sane environment was not GC-safe in the REPL. 2007-05-11 Fix: `'(,(+ 1 2)) reduced to '(,(+ 1 2)). It now (correctly) reduces to '(3). 2007-05-05 Fix: clauses of CASE could not contain multiple expressions. 2007-04-26 Made missing program file an error condition in -f program command line option. 2007-04-24 Fix: local ports of WITH-INPUT-FROM-FILE and WITH-OUTPUT-TO-FILE were not GC-safe. Added -q (quiet) command line option. Updated man page. 2007-04-21 Made more cosmetical changes. 2007-04-20 Made some minor cosmetical changes. 2007-04-19 Simplified evaluator (saved one unsave/save). 2007-04-18 Added patches to make s9.c compile on newer MSC compilers. Thanks, Blake McBride. De-cluttered code by replacing #ifdefs with ifs. Added 64-bit mode for bignum integers for faster operation on 64-bit systems. Fixed LET* with multiple expression body. 2007-04-15 Added error condition for DEFINE in expression context. Updated test suite. 2007-04-14 Implemented local DEFINEs by rewriting them to LAMBDA and SET! (like LETREC). Added rc file support: if a ~/.s9fes/rc file exists, it is loaded at start-up time. Updated test suite. Updated man page. 2007-04-13 Implemented QUASIQUOTE, UNQUOTE, and UNQUOTE-SPLICING. Added EXPAND-QUASIQUOTE to library. This procedure rewrites quasiquoted expressions to expressions not using quasiquotation. Note: you currently cannot quasiquote improper lists. 2007-04-12 Documented ** (most recent top level result). Created a distribution archive. Added "install" target to Makefile. 2007-04-11 Added "additions" section to man page. It describes the non-R5RS procedures of S9fES. Applied some minor optimizations to EXPAND-SYNTAX. Moved part of syntax transformation code into s9.c. Added DELAY and FORCE to library. Added ** symbol, which always binds to the result most recently returned to the REPL. 2007-04-10 Added SIGINT (abort input or interrupt program) and SIGQUIT (emergency exit) handlers. If your system does not support POSIX signals, compile with -DNO_SIGNALS to omit signal handling. Added -ansi -pedantic compilation flags, removed some flaws. Implemented DEFINE-SYNTAX and SYNTAX-RULES special form handlers. Added SYNTAX->LIST helper (non-R5RS; used in syntax expansion). Added EXPAND-SYNTAX (non-R5RS), which performs syntax transformation behind the scenes. Note: This is an import of the potentially buggy SketchyLISP syntax transformer. To be improved. Added CASE syntax to library. Added LET* syntax to library. Updated test suite. 2007-04-09 Added to library: STRING, VECTOR. Added to library: NUMBER->STRING, STRING->NUMBER. Added to library: CALL-WITH-INPUT-FILE, CALL-WITH-OUTPUT-FILE, newline, WITH-INPUT-FROM-FILE, WITH-OUTPUT-TO-FILE. Updated test suite. Added -f program command line option. Added s9(1) man page. 2007-04-08 Added library s9.scm which is automatically loaded. Added list procedures to library: APPEND, ASSOC, ASSQ, ASSV, CAAR...CDDDDR, LENGTH, LIST, LIST-REF, LIST-TAIL, LIST?, MEMBER, MEMQ, MEMV, NULL?, REVERSE. Added equivalence predicates to library: EQUAL?, EQV?. Added type predicate to library: NUMBER?, PORT?. Added NOT procedure to library. Added higher order procedures to library: FOR-EACH, MAP, FOLD-LEFT (R6RS), FOLD-RIGHT (R6RS), MAP-CAR (non-R5RS). Added arithmetic functions to library: ABS, EVEN?, EXPT, GCD, LCM, MAX, MIN, MODULO, NEGATIVE?, ODD?, POSITIVE?, SQRT, ZERO?. Updated test suite. 2007-04-07 Implemented CHAR-DOWNCASE, CHAR-LOWER-CASE?, CHAR-NUMERIC?, CHAR-UPCASE, CHAR-UPPER-CASE?, CHAR-WHITESPACE?. Implemented STRING-LENGTH, STRING-REF, STRING-SET!. Implemented STRING-APPEND, STRING-COPY, STRING-FILL!, SUBSTRING. Fixed a bug in string/vector pool compaction. Implemented MAKE-STRING, MAKE-VECTOR, VECTOR-FILL!. Implemented <=, >, >=. Updated test suite. 2007-04-06 Implemented OPEN-INPUT-FILE, OPEN-OUTPUT-FILE, CLOSE-INPUT-PORT, CLOSE-OUTPUT-PORT. Made the garbage collector close unused ports. Implemented SET-INPUT-PORT!, SET-OUTPUT-PORT!, both non-R5RS. These will facilitate the implementation of WITH-INPUT-FROM-FILE and WITH-OUTPUT-TO-FILE. Fix: made READ-CHAR and PEEK-CHAR return the EOF object on EOF. Implemented CHAR-CI<=?, CHAR-CI=?, CHAR-CI>?, CHAR<=?, CHAR=?, CHAR>?. Implemented STRING-CI<=?, STRING-CI=?, STRING-CI>?, STRING<=?, STRING=?, STRING>?. Updated test suite. 2007-04-05 Implemented I/O ports. Implemented CURRENT-INPUT-PORT AND CURRENT-OUTPUT-PORT. Implemented INPUT-PORT?, OUTPUT-PORT?, EOF-OBJECT?. Fixed sign error in * with odd numbers of arguments. Updated test suite. Implemented READ, WRITE, DISPLAY. Implemented READ-CHAR, WRITE-CHAR, PEEK-CHAR. 2007-04-04 Chased a GC bug due to C's braindead order of evaluation. Growing memory pools work fine now. Fixed some potential GC leaks in the bignum code. Made QUOTIENT and REMAINDER handle negative signs correctly. Brought test suite up to date. 2007-04-03 Started test suite. Fixed a few bugs in cond. Implemented SET-CAR!, SET-CDR!, AND VECTOR-SET!. Implemented growing memory pools. 2007-04-02 Moved most of the type checking code to a central procedure. Implemented type predicates: BOOLEAN?, CHAR?, INTEGER?, PAIR?, PROCEDURE?, STRING?, SYMBOL?, VECTOR?. Implemented type conversion procedures: CHAR->INTEGER, INTEGER->CHAR, LIST->STRING, LIST->VECTOR, STRING->LIST, STRING->SYMBOL, SYMBOL->STRING, VECTOR->LIST. Implemented vector procedures: VECTOR-LENGTH, VECTOR-REF. Implemented WRONG (non-R5RS). Implemented integer (bignum) =. Implemented CHAR=? and STRING=?. 2007-04-01 Implemented COND. Implemented LOAD. 2007-03-31 Implemented integer (bignum) *, QUOTIENT, and REMAINDER. 2007-03-30 Implemented LETREC. Started implementation of bignum arithmetics. Implemented integer (bignum) <, +, -. 2007-03-29 Implemented CONS, CAR, CDR, EQ?. Simplified the garbage collector. Removed tedious and buggy variable capture code from lambda. 2007-03-28 Chased a GC leak, found it, splat! --> * Implemented primitive procedure framework. Implemented APPLY. 2007-03-27 Implemented DEFINE (dynamically scoped!). Fixed a few bugs in variable capture (could not test this earlier). Implemented let by rewriting it as an application of LAMBDA. 2007-03-26 Modified the evaluator to get rid of the L-stack. Modified the evaluator to get rid of the B-stack. Implemented BEGIN, IF, AND, OR, and SET!. 2007-03-25 Imported the evaluator from Sketchy LISP. S9fES can now run ((lambda (x) (x x)) (lambda (x) (x x))). In constant space! 2007-03-24 Implemented lambda abstraction. 2007-03-23 Took the garbage collector, reader, and printer from Sketchy LISP and gave them an overhaul. S9fES supports R6RS-style #|...|# and #;form comments. s9/s9core.txt000644 001751 001751 00000214273 13201113763 012774 0ustar00nmhnmh000000 000000 ================================================================ | S9CORE | | A Toolkit for Implementing Dynamic Languages | | Mk IIIc | ================================================================ Nils M Holm, 2007-2017 In the public domain ---------------------------------------------------------------- RATIONALE ---------------------------------------------------------------- Dynamic languages typically require some basic infrastructure that is common in their implementations, including - garbage collection - primitive functions - dynamic type checking - bignum arithmetics" - heap images S9core offers all of the above, and some more, in a single object file that can be linked against a dynamic language implementation. It takes care of all the nitty gritty stuff and allows the implementor to focus on the design of the language itself. ---------------------------------------------------------------- FEATURES ---------------------------------------------------------------- - Precise, constant-space, stop-the-world garbage collection with vector pool compaction (defragmentation) and finalization of I/O ports - Non-copying GC, all nodes stay in their original locations - Bignum (unbounded-precision) integer arithmetics - Decimal-based, platform-independent real number arithmetics - Persistent heap images - Type-checked primitive functions - Symbol identity - Memory allocation on heap exclusively (no malloc() until the heap grows) - A basis for implementing interpreters, runtime libraries, etc - Statically or dynamically linked - Available on Unix, Plan 9, and in C89/POSIX environments ---------------------------------------------------------------- REFERENCE MANUAL ---------------------------------------------------------------- ===== SETUP AND NAMESPACE ====================================== A module that intends to use the S9core tool kit must include the S9core header using #include As of Mk II, the tool kit has a separate name space which is implemented by beginning all symbol names with a S9_ or s9_ prefix. However, many symbols can be "imported" by adding #include Doing so will create aliases of most definitions with the prefix removed, so you can write, for instance: cons(a, cons(b, NIL)) instead of s9_cons(a, s9_cons(b, S9_NIL)) There are some symbol names that will not have aliases, mostly tuneable parameters of s9core.h. Those names will print with their prefixes in this text. All other names will have their prefixes removed. When a module wants to use S9core functions without importing them, the following rules apply: A lower-case function or macro name is prefixed with s9_, e.g. bignum_add() becomes s9_bignum_add(). A capitalized function or macro name has its first letter converted to lower case and an S9_ prefix attached, e.g.: Real_exponent becomes S9_real_exponent. An upper-case symbol gets an S9_ prefix, e.g.: NIL becomes S9_NIL. ----- S9_VERSION ----------------------------------------------- The S9_VERSION macro expands to a string holding the S9core version in "YYYYMMDD" (year, month, day) format. ===== C-LEVEL DATA TYPES ======================================= At C level, there are only two data types in S9core. Dynamic typing is implemented by adding type tags to objects on the heap. ----- cell ----------------------------------------------------- A "cell" is a reference to an object on the heap. All objects are addressed using cells. A cell is wide enough to hold a pointer on the host platform (typically a ptrdiff_t. Example: cell x, y; ----- PRIM (struct S9_primitive) ------------------------------- A PRIM is a structure containing information about a primitive procedure: struct S9_primitive { char *name; cell (*handler)(cell expr); int min_args; int max_args; int arg_types[3]; }; The name field names the primitive procedure. The handler is a pointer to a function from cell to cell implementing the primitive function. Because a cell may reference a list or vector, functions may in fact have any number of arguments (and, for that matter, return values). The min_args, max_args, and arg_types[] fields define the type of the primitive function. min_args and max_args specify the expected argument count. When they are equal, the argument count is fixed. When max_args is less then zero, the function accepts any number of arguments that is greater than or equal to min_args. The arg_types[] array holds the type tags of the first three argument of the primitive. Functions with more than three arguments must check additional arguments internally. Unused argument slots can be set to T_ANY (any type accepted). Example: PRIM Prims[] = { { "cons", p_cons, 2, 2, { T_ANY, T_ANY, T_ANY } }, { "car", p_car, 1, 1, { T_PAIR, T_ANY, T_ANY } }, { "cdr", p_cdr. 1, 1, { T_PAIR, T_ANY, T_ANY } }, { NULL } }; Where p_cons, p_car, and p_cdr are the functions implementing the corresponding primitives. ===== CALLING CONVENTIONS ====================================== All S9core functions protect their parameters from the garbage collector so it is safe, for example, to write make_real(1, 0, make_integer(x)); or cell n = cons(c, NIL); n = cons(b, n); n = cons(a, n); In the first case, the integer created by make_integer() will be protected in the application of make_real(). In the second example, the object /c/ will be protected in the first call, and the list /n/ will be protected in all subsequent applications cons(). Note that the objects /b/ and /a/ are not protected during the first call and /a/ is not protected during the second call, though. Use save() and unsave() to protect objects temporarily. ===== INITIALIZATION AND SHUTDOWN ============================== ----- void s9_init(cell **extroots); --------------------------- The s9_init() function initializes the memory pools, connects the first three I/O ports to stdin, stdout, and stderr, and sets up the internal S9core structures. It must be called before any other S9core functions can be used. The extroots parameter is a pointer to an array of addresses of cells that will be protected from the garbage collector (the so-called "GC roots"). The last array member must be NULL. Because cells can reference trees, lists, or vectors, larger structures may be protected from GC by including their handles in this array. Example: cell Environment; cell *GC_roots[] = { &Environment, NULL }; ... s9_init(GC_roots); ----- void s9_fini(void); -------------------------------------- The s9_fini() function shuts down S9core and releases all memory allocated by it. This function is normally never called, because clean-up is done by the operating system. The only reason to call it is to prepare for the re-initialization of the toolkit, for example to recover from a failed image load (see load_image()). ----- MEMORY ALLOCATION ---------------------------------------- ----- S9_NODE_LIMIT -------------------------------------------- ----- S9_VECTOR_LIMIT ------------------------------------------ The S9_NODE_LIMIT and S9_VECTOR_LIMIT constants specify the maximum sizes of the node pool and the vector pool, respectively. The "pools" are used to allocate objects at run time. Their sizes are measured in "nodes" for the node pool and cells for the vector pool. Both sizes default to 14013 times 1024 (14,013K). The size of a cell is the size of a pointer on the host platform. The size of a node is two cells plus a char. So the total node memory limit using the default settings on a 64-bit host would be: 14013 times 1024 times (2 times 8+1) = 243,938,304 bytes The default vector pool limit would be: 14013K cells = 114,794,496 bytes At run time, the S9core toolbox will /never/ allocate more memory than the sum of the above (plus the small amount allocated to primitive functions at initialization time). When S9core runs out of memory, it will print a message and terminate program execution. However, a program can request to handle memory allocation failure itself by passing a handler to the mem_error_handler() function (further explanations can be found below). The amount allocated to S9core can be changed by the user. See the set_node_limit() and set_vector_limit() functions for details. ----- void mem_error_handler(void (*h)(int src)); -------------- When a function pointer is passed to mem_error_handler(), S9core will no longer terminate program execution when a node or vector allocation request fails. The request will /succeed/ and the function passed to mem_error_handler() will be called. **************************************************************** The function is then required to handle the error as soon as possible, for example by interrupting program execution and returning to the REPL, or by signalling an exception. **************************************************************** The integer argument passed to a memory error handler will identify the source of the error: 1 denotes the node allocator and 2 indicates the vector allocator. Allocation requests can still succeed in case of a low memory condition, because S9core never allocates more than 50% of each pool. (This is done, because using more than half of a pool will result in GC thrashing, which would reduce performance dramatically.) As soon as a memory error handler has been invoked, thrashing /will/ start immediately. Program execution will slow down to a crawl and eventually the allocator will fail to recover from a low-memory condition and kill the process, even with memory error handling enabled. The default handler (which just terminates program execution) can be reinstalled by passing NULL to mem_error_handler(). ----- void set_node_limit(int k); ------------------------------ These functions modify the node pool and vector pool memory limits. The value passed to the function will become the new limit for the respective pool. The limits must be set up immediately after initialization and may not be altered once set. Limits are specified in kilo nodes, i.e. they will be multiplied by 1024 internally. Setting either value to zero will disable the corresponding memory limit, i.e. S9core will grow the memory pools indefinitely until physical memory allocation fails. This may cause massive swapping in memory-heavy applications. S9core memory pools both start with a size of 32768 units (S9_INITIAL_SEGMENT_SIZE constant) and grow exponentially to a base of 3/2. With the default settings, the limit will be reached after growing either pool for 15 times. Note that actual memory limits all have the form 32768 * 1.5^n, so a limit that is not constructed using the above formula will probably be smaller than expected. Reasonable memory limits (using the default segment size) are listed in figure 1. As can be seen in the table, the minimal memory footprint of S9core is 416K bytes on 32-bit and 800K bytes on 64-bit systems. In order to obtain a smaller initial memory footprint, the S9_INITIAL_SEGMENT_SIZE constant has to be reduced and the table in figure 1 has to be recalculated. Limit 64-bit memory 32-bit memory --------- ------------- ------------- 32 800K 416K 48 1200K 625K 72 1800K 937K 108 2700K 1405K 162 4050K 2107K 243 6075K 3160K 364 9100K 4733K 546 14M 7089K 820 21M 11M 1,230 31M 16M 1,846 46M 24M 2,768 69M 36M 4,152 104M 54M 6,228 156M 81M 9,342 234M 121M --------------------------------------- 14,013 350M 182M --------------------------------------- 21,019 525M 273M 31,529 788M 410M 47,293 1182M 615M 70,939 1773M 922M 106,409 2660M 1383M 159,613 3990M 2075M 239,419 5985M 3112M 359,128 8978M 4669M 538,692 13G 7003M 808,038 20G 10G 1,212,057 30G 16G 1,818,085 45G 24G 2,727,127 68G 35G 4,090,690 102G 53G 6,136,034 153G 80G --------------------------------------- Fig 1. Memory Limits ----- ARITHMETICS ---------------------------------------------- ----- S9_DIGITS_PER_CELL --------------------------------------- ----- S9_INT_SEG_LIMIT ----------------------------------------- S9_DIGITS_PER_CELL is the number of decimal digits that can be represented by a cell and S9_INT_SEG_LIMIT is the smallest integer that can /not/ be represented by an "integer segment" (which has the size of one cell). The integer segment limit is equal to 10^S9_DITIGS_PER_CELL. A cell is called an integer segment in S9core arithmetics, because numbers are represented by chains of cells (segments). The practical use of the S9_INT_SEG_LIMIT constant is that bignums that are smaller than this limit can be converted to (long) integers just be extracting their first segment. These values are /not/ tunable. S9_DIGITS_PER_CELL is 18 on 64-bit machines, 9 on 32- bit machines, and (theoretically) 4 on 16-bit machines. ----- S9_MANTISSA_SEGMENTS ------------------------------------- ----- S9_MANTISSA_SIZE ----------------------------------------- S9_MANTISSA_SEGMENTS his is the number of integer segments (see above) in the mantissae of real numbers. The default is one segment (18 digits of precision) on 64-bit hosts and two segments (also 18 digits) on 32-bit platforms. Each additional mantissa segment increases precision by S9_DIGITS_PER_CELL (see above), but also slows down real number computations. This is a compile-time option and cannot be tweaked at run time. S9_MANTISSA_SIZE is the number of decimal digits in a mantissa. It is used in the computation of various values, such as Epsilon. ===== S9CORE TYPES ============================================= S9core data types are pretty LISP- or Scheme-centric, but most of them can be used in a variety of languages. Each type may be associated with a predicate testing for the type, an allocator creating an object of the given type, and one or more accessors that extract values from the type. Predicates always return 0 (false) or 1 (true). Type predicates succeed (return 1) if the object passed to them is of the given type. ----- SPECIAL VALUES ------------------------------------------- Special values are constant, unique, can be compared with ==, and have no allocators. ................................................................ Type: NIL Predicate: x == NIL NIL ("Not In List") denotes the end of a list, an empty list, or an empty return value. For example, to create a list of the objects /a/, /b/, and /c/, the following S9core code would be used: cell list = cons(c, NIL); list = cons(b, list); list = cons(a, list); See also: T_LIST ................................................................ Type: END_OF_FILE Predicate: eof_p(x) x == END_OF_FIL END_OF_FILE is an object that is reserved for indicating the end of file when reading from an input source. The eof_p() predicate returns truth only for the END_OF_FILE object. ................................................................ Type: UNDEFINED Predicate: undefined_p(x) x == UNDEFINED The UNDEFINED value is returned by a function to indicate that its value for the given arguments is undefined. For example, bignum_divide(One, Zero) would return UNDEFINED. ................................................................ Type: UNSPECIFIC Predicate: unspecific_p(x) x == UNSPECIFIC The UNSPECIFIC value can be returned by functions to indicate that their return value is of no importance and should be ignored. ................................................................ Type: USER_SPECIALS Predicate: special_p() When more special values are needed, they should be assigned /decreasing/ values starting at the value of the USER_SPECIALS constant. The predicate special_p() will return truth for all special values, including user-defined ones. Examples: #define TOP (USER_SPECIALS-0) #define BOTTOM (USER_SPECIALS-1) ................................................................ Type: VOID Predicate: x == VOID VOID denotes the absence of a value. While UNSPECIFIC is typically /returned/ by a function to indicate that its value is uninteresting, VOID may be /passed/ to a function to indicate that the corresponding argument may be ignored. ----- TAGGED TYPES --------------------------------------------- A "tagged" object is a compound data object (pair, tree) with a type tag in its first slot. Tagged objects typically carry some payload, such as an integer value, an I/O port, or a symbol name. The internal structure of a tagged object does not matter; it is created using an allocator function and its payload is accessed using one or multiple accessor functions. ----- type_tag(x) ---------------------------------------------- The type_tag() accessor extracts the type tag, like T_BOOLEAN or T_INTEGER, from the given object. When the object does not have a type tag, it returns a special value, T_NONE. ................................................................ Type: T_ANY When used in a PRIM structure, this type tag matches any other type (i.e. the described primitive procedure will accept any type in its place). ................................................................ Type: T_BOOLEAN Allocator: TRUE, FALSE Predicate: boolean_p(x) The TRUE and FALSE objects denote logical truth and falsity. ................................................................ Type: T_CHAR Allocator: make_char(int c) Predicate: char_p(x) Accessor: int char_value(x) T_CHAR objects store single characters. The make_char() function expects the character to store, and char_value() retrieves the character. Example: make_char('x') ................................................................ Type: T_INPUT_PORT Allocator: make_port(int portno, T_INPUT_PORT) Predicate: input_port_p(x) Accessor: int port_no(x) The make_port() allocator boxes a port handle. The port handle must be obtained by one of the I/O routines before passing it to this function. port_no() returns the port handle stored in an T_INPUT_PORT (or T_OUTPUT_PORT) object. Example: cell p = open_input_port(path); if (p >= 0) return make_port(p, T_INPUT_PORT); ................................................................ Type: T_INTEGER Allocator: make_integer(cell segment) Predicate: integer_p(x) Accessor: cell bignum_to_int(x) The make_integer() function creates a single-segment bignum integer in the range from -10^S9_DITIGS_PER_CELL + 1 to 10^S9_DITIGS_PER_CELL - 1 To create larger bignum integers, the string_to_bignum() function has to be used. The bignum_to_int() accessor returns the value of a single-segment bignum integer or UNDEFINED, if the bignum has more than a single segment. There is no way to convert multi-segment bignums to a native C type. Example: cell x = make_integer(-12345); int i = bignum_to_int(x); ................................................................ Type: T_LIST T_PAIR Allocator: cons(cell car_val, cell cdr_val) Predicate: pair_p(x) Accessor: cell car(x) cell cdr(x) The difference between the T_PAIR and T_LIST type tags is that T_LIST also includes NIL, which T_PAIR does not. Both type tags are used for primitive procedure type checking exclusively. The cons() allocator returns an ordered pair of any two values. It is in fact an incarnation of the LISP function of the same name. The accessors car() and cdr() retrieve the first and second value from a pair, respectively. pair_p() succeeds for pairs created by cons(). T_LIST corresponds to pair_p(x) || x == NIL Further accessors, like caar() and friends, are also available and will be explained later in this text. Example: cons(One, NIL); /* list */ cell x = cons(One, Two); /* pair */ car(x); /* One */ cdr(x); /* Two */ ................................................................ Type: T_OUTPUT_PORT Allocator: make_port(int portno, T_OUTPUT_PORT) Predicate: output_port_p(x) Accessor: int port_no(x) See T_INPUT_PORT, above, for details. Example: make_port(port_no, T_OUTPUT_PORT); ................................................................ Type: T_PRIMITIVE Allocator: make_primitive(PRIM *p) Predicate: primitive_p(x) Accessor: int prim_slot(x) int prim_info(x) The make_primitive() function allocates a slot in an internal primitive function table, fills in the information in the given PRIM structure, and returns a primitive function object referencing that table entry. The prim_info() function retrieves the stored information (as a PRIM *). The prim_slot() accessor returns the slot number allocated for a given primitive function object in the internal table. Table offsets can be used to identify individual primitive functions. See the the discussion of the PRIM structure for an example of how to set up a primitive function. Given the table shown there, the following code would create the corresponding T_PRIMITIVE objects: for (i=0; p[i].name; i++) { prim = make_primitive(&p[i]); ... } ................................................................ Type: T_FUNCTION Predicate: function_p(x) Function objects are deliberately underspecified. The user is required to define their own function object structure and accessors. For example, a LISP function allocator might look like this: cell make_function(cell args, cell body, cell env) { /* args and body should be GC-protected! */ cell fun = cons(env, NIL); fun = cons(body, fun); fun = cons(args, fun); return new_atom(T_FUNCTION, fun); } Given the structure of this function object, the corresponding accessors would look like this: #define fun_args(x) (cadr(x)) #define fun_body(x) (caddr(x)) #define fun_env(x) (cadddr(x)) ................................................................ Type: T_REAL Allocator: make_real(int s, cell e, cell m) Make_real(int f, cell e, cell m) Predicate: real_p(x) Accessor: cell real_mantissa(x) cell real_exponent(x) Real_flags(x) A real number consists of three parts, a "mantissa" (the digits of the number), an exponent (the position of the decimal point), and a "flags" field, currently just containing the sign of the number. The value of a real number is sign * mantissa * 10^exponent The real_mantissa() and real_exponent() functions extract the mantissa and exponent, respectively. When applied to a bignum integer, the mantissa will be the number itself and the exponent will always be 0. Note that real_mantissa returns a bignum integer, but real_exponent returns an unboxed, cell-sized integer. The Real_flags() accessor can only be applied to real numbers. It extracts the flags field. The make_real() function is the principal real number allocator. It expects a sign /s/ (-1 or 1), an exponent as single cell, and a mantissa in the form of a bignum integer. When the mantissa is too large, the function will return UNDEFINED. Make_real() is a "quick and dirty" allocator. It expects a flags field in the place of a sign, a chain of integer segments instead of a bignum, and it does not perform any overflow checking. **************************************************************** Caution: This function can create an invalid real number! **************************************************************** Examples: cell m = make_integer(123); cell r = make_real( 1, 0, m); /* 123 */ cell r = make_real( 1, 10, m); /* 1.23e+12 */ cell r = make_real(-1, -5, m); /* -0.00123 */ ................................................................ Type: T_STRING Allocator: make_string(char *s, int k) Predicate: string_p(x) Accessor: char *string(x) int string_len(x) The make_string() function creates a string of the length /k/ and initializes it with the content of /s/. When the length /n/ of /s/ is less than /k/, the last /k-n/ characters of the resulting string object will be undefined. Strings are counted /and/ NUL-terminated. The counted length of a given string is returned by the string_len() function, the C string length of /x/ is "strlen(string(x))" . ................................................................ The string() accessor returns a pointer to the char array holding the string. **************************************************************** Note: no string obtained by string() or symbol_name() may be passed to make_string() as an initialization string, because vector objects (including strings and symbols) may move during heap compaction. **************************************************************** The proper way to copy a string is int k = string_len(source); cell dest = make_string("", k-1); memcpy(string(dest), string(source), k); Alternatively, the copy_string() function may be used. ................................................................ Type: T_SYMBOL Allocator: make_symbol(char *s, int k) symbol_ref(char *s) Predicate: symbol_p(x)\fP" Accessor: char *symbol_name(x) int symbol_len(x) Typically, the symbol_ref() function is used to create or reference a symbol. A symbol is a unique string with an identity operation defined on it. I.e. referencing the same string twice using symbol_ref() will return /the same symbol/. Hence symbols can be compared using the == operator. The make_symbol() function creates an uninterned symbol, i.e. a symbol with no identity (which cannot be compared or referenced). In a typical implementation, this function will not be used. See the T_STRING description for further details and caveats. Example: cell sym = symbol_ref("foo"); ................................................................ Type: T_SYNTAX Predicate: syntax_p(x) Like function objects, syntactic abstractions ("macros") are deliberately underspecified. Typically, the value of a T_SYNTAX object would be a T_FUNCTION object. ................................................................ Type: T_VECTOR Allocator: make_vector(int k) Predicate: vector_p(x) Accessor: cell *vector(x) int vector_len(x) The make_vector() function returns a vector of /k/ elements (slots) with all slots set to UNDEFINED. vector() returns a pointer to the slots of the given vector, vector_len() returns the number of slots. Example: cell v = make_vector(100); save(v); for (i=0; i<100; i++) { x = make_integer(i); vector(v)[i] = x; } unsave(1); **************************************************************** Note: the result of vector() may not be used on the left side of an assignment where the right side allocates any objects. When in doubt, first assign the value to a temporary variable and then the variable to the vector. For an explanation see T_STRING. **************************************************************** ................................................................ Type: T_CONTINUATION Predicate: continuation_p(x) A "continuation" object is used to store the value of a captured continuation (as in Scheme's call/cc). Its implementation is left to the user. ----- ADDITIONAL ALLOCATORS ------------------------------------ ----- cell cons3(cell a, cell d, int t); ----------------------- The cons3() function is the principal node allocator of S9core. It is like cons(), but has an additional parameter for the "tag" field. The tag field of a node assigns specific properties to a node. For example, it can turn a node into an "atom", a vector reference, or an I/O port reference. In fact, cons() is a wrapper around cons3() that supplies an empty (zero) tag field. The most interesting user-level application of cons3() is maybe the option to mix in a CONST_TAG in order to create an immutable node. Note though, that immutability is not enforced by S9core itself, because it never alters any nodes. However, implementations using S9core can use the constant_p() predicate to check for immutability. Also note that "atoms" are typically created by the new_atom() allocator, explained below. ----- cell copy_string(cell x); -------------------------------- This function creates an new string object with the same content as the given string object. ----- new_atom(x, d) ------------------------------------------- ----- atom_p(x) ------------------------------------------------ An "atom" is a node with its atom flag set. Unlike a "cons" node, as delivered by cons(), an atom has no reference to another node in its car field. Instead of a reference, it can carry any value in the car field, for example: the character of a character object, a bignum integer segment, or a type tag. The new_atom() function expects any value in the /x/ parameter and a node reference in the /d/ parameter. Tagged S9core objects are composed of multiple atoms. For example, the following program would create a "character" object containing the character 'x' : cell n = new_atom('x', NIL); n = new_atom(T_CHAR, n); (Don't do this, though; use make_char() instead!) The atom_p() function checks whether the given node is an atom. S9core atoms encompass all the special values (like NIL, TRUE, END_OF_FILE, etc), all nodes with the atom flag set (including all tagged types), and all vector objects (see below). In fact, only "conses" (as delivered by cons()) are considered to be non-atomic). ----- cell new_port(void); ------------------------------------- The new_port() function returns a handle to a port, but does not assign any FILE to it. A file can be assigned by using the return value of new_port() as an index to the Ports[] array. A negative return value indicates failure (out of free ports). Example: int p = new_port(); if (p >= 0) { Ports[p] = fopen(file, "r"); } ----- cell new_vec(cell type, int size); ----------------------- This function allocates a new vector. A vector object has a type tag in its car field and a reference into the vector pool in its cdr field, that is, neither of its fields reference any other node. The /type/ parameter is the type tag to be installed in the new vector atom and /size/ is the number /bytes/ to allocate in the vector pool. The newly allocated segment of the vector pool will be left uninitialized except when /type/ is T_VECTOR. Slots of T_VECTOR objects will be initialized with NIL. Example: new_vec(T_STRING, 100); new_vec(T_VECTOR, 100 * sizeof(cell)); ----- save(n) -------------------------------------------------- ----- cell unsave(int k); -------------------------------------- save() saves an object on the internal S9core stack and unsave(n) removes /n/ elements from the stack and returns the one last removed (i.e. the previously /n^th/ element on the stack). The S9core stack is mostly used to protect objects from being recycled by the GC. Removing an element from an empty stack will cause a fatal error and terminate program execution. Example: cell a = cons(One, NIL); save(a) ; cell b = cons(Two, NIL); /* a is protected */ b = cons(b, NIL); /* still protected */ a = unsave(1); a = cons(a, b); ----- ADDITIONAL PREDICATES ------------------------------------ ----- constant_p(x) -------------------------------------------- This predicate succeeds, if the object passed to it has its CONST_TAG set, i.e. if it should be considered to be immutable. Example: if (constant_p(x)) /* error: x is constant */ ----- number_p(x) ---------------------------------------------- The number_p() predicate succeeds, if its argument is either a bignum integer or a real number. ----- ADDITIONAL ACCESSORS ------------------------------------- ----- caar(x)\fP ... \f[CB]cddddr(x) --------------------------- These are the usual LISP accessors for nested lists and trees. For instance, cadr(x) denotes the "car of the cdr of x". All names can be decoded by reading their "a"s and "d"s from the right to the left, where each "a" denotes a car accessor, and each "d" a cdr, e.g. cadadr of ((1 2) (8 9)) = cadar of ((8 9)) = cadr of (8 9) = car of (9) = 9 ----- tag(x) --------------------------------------------------- The tag() accessor extracts the "tag" field of a node. It is mostly used in the implementation of type predicates, to find out whether a node has its S9_ATOM_TAG set. For instance: #define T_DICTIONARY (USER_SPECIALS-1) #define dictionary_p(n) \ (!special_p(n) && \ (tag(n) & S9_ATOM_TAG) && \ car(n) == T_DICTIONARY) ===== PRIMITIVE PROCEDURES ===================================== A S9core primitive function consists of a PRIM entry describing the primitive, and a "handler" implementing it. Here is a PRIM structure describing the Scheme procedure list-tail which, given a list and an integer /n/, returns the tail starting at the /n^th/ element of the list. { "list-tail", p_list_tail, 2, 2, { T_LIST, T_INTEGER, T_ANY } }, The corresponding handler, p_list_tail(), looks like this: cell pp_list_tail(cell x) { cell p, n; n = bignum_to_int(cadr(x)); if (n == UNDEFINED) return error("int argument too big"); for (p = car(x); p != NIL; p = cdr(p), n--) { if (!pair_p(p)) return error("not a proper list"); if (n <= 0) break; } if (n != 0) return error("int argument too big"); return p; } Like all primitive handlers, p_list_tail() is a function from cell to cell, but the argument it receives is actually a T_LIST of arguments, so car accesses the first argument and cadr the second one. The function first extracts the value of the integer argument and checks for overflow (multi-segment bignum). It then traverses the list argument, decrementing /n/ until n=0 or the end of the list is reached. After some final error checking, it returns the tail of the given list. Primitive handlers usually do not have to type-check their arguments, because there is a function that can do that /before/ dispatching the handler. See below. ----- char *typecheck(cell f, cell a); ------------------------- The typecheck() function expects a primitive function object /f/ and an argument list /a/. It checks the types of the arguments in /a/ against the type tags in the PRIM structure of /f/. When all arguments match, it returns NULL. When a type mismatch is found, the function returns a string explaining the nature of the type error in plain English. For example, passing a T_LIST and a T_CHAR to list-tail would return the message list-tail: expected integer in argument #2 The program could then add a visual representation of the actual arguments that were about to be passed to the handler. ----- cell apply_prim(cell f, cell a); ------------------------- The apply_prim() function extracts the handler from the primitive function object /f/, calls it with the parameter /a/, and delivers the return value of the handler. apply_prim() itself does /not/ protect its arguments. Doing so is in the responsibility of the implementation. ===== SYMBOL MANAGEMENT ======================================== ----- cell find_symbol(char *s); ------------------------------- This function searches the internal symbol list for the given symbol. When the symbol is in the list ("interned"; see also intern_symbol(), below), then it returns a reference to it. Otherwise, it returns NIL. ----- cell intern_symbol(cell y); ------------------------------ This function adds the given symbol to an internal list of symbols. Symbols contained in that list are called "interned" symbols, and only those symbols can be checked for identity (i.e. compared with C's == operator). The intern_symbol() function should only be used to intern "uninterned" symbols, i.e. symbols created by make_symbol(). Symbols created by symbol_ref() are automatically interned. Note: while uninterned symbols have their uses, almost all common use cases rely on interned symbols. ----- cell symbol_to_string(cell x); --------------------------- ----- cell string_to_symbol(cell x); --------------------------- symbol_to_string() returns a string object containing the name of the given symbol. string_to_symbol() is the inverse operation; it returns a symbol with the name given as its string argument. It also makes sure that the new symbol is interned. ===== BIGNUM ARITHMETICS ======================================= Bignum arithmetics can never overflow, but performance will degrade linearly as numbers grow bigger. ----- Zero, One, Two, Ten -------------------------------------- These are constants for common values, so you do not have to allocate them using make_integer(). ----- cell bignum_abs(cell a); --------------------------------- This function returns the absolute value (magnitude) of its argument, i.e. the original value with a positive sign. ----- cell bignum_add(cell a, cell b); ------------------------- bignum_add() adds two integers and returns their result. ----- cell bignum_divide(cell a, cell b); ---------------------- bignum_divide() divides /a/ by /b/ and returns both the truncated integer quotient trunc(a/b) and the truncated division remainder a-trunc(a/b)*b (where trunc removes any non-zero fractional digits from its argument). The result is delivered as a cons node with the quotient in the car and the remainder in the cdr field. For example, given cell a = make_integer(-23), b = make_integer(7); cell r = bignum_divide(a, b); the result would be equal to car(r) = make_integer(-3); /* trunc(-23/7) */ cdr(r) = make_integer(-2); /* -23 - trunc(-23/7)*7 */ ----- int bignum_equal_p(cell a, cell b); ---------------------- This predicate returns 1, if its arguments are equal. ----- int bignum_even_p(cell a); ------------------------------- This predicate returns 1, if its argument is divisible by 2 with a remainder of 0. See bignum_divide(). ----- int bignum_less_p(cell a, cell b); ----------------------- This predicate returns 1, if its argument /a/ has a smaller value than its argument /b/. ----- cell bignum_multiply(cell a, cell b); -------------------- bignum_multiply() multiplies two integers and returns their product. ----- cell bignum_negate(cell a); ------------------------------ This function returns its argument with its sign reversed. ----- cell bignum_shift_left(cell a, int fill); ---------------- The bignum_shift_left() function shifts its argument /a/ to the left by one decimal digit and then replaces the rightmost digit with /fill/. Note that 0<=fill<=9 must hold! Example: cell n = make_integer(1234); bignum_shift_left(x, 5); /* 12345 */ ----- cell bignum_shift_right(cell a); ------------------------- bignum_shift_right() shifts its argument to the right by one decimal digit. It returns a node with the shifted argument in the car part. The cdr part will contain the digit that "fell out" on the right side. Example: cell n = make_integer(12345); cell r = bignum_shift_right(n); The result would be equal to the following: car(r) = make_integer(1234); cdr(r) = make_integer(5); ----- cell bignum_subtract(cell a, cell b); -------------------- This function returns the difference /a-b/. ----- cell bignum_to_real(cell a); ----------------------------- The bignum_to_real() function converts a bignum integer to a real number. Note that for big integers, this will lead to a loss of precision. E.g., converting the integer 340282366920938463463374607431768211456 to real on a machine with a mantissa size of 18 digits will yield: 3.40282366920938463e+38" Converting it back to bignum integer will give: 340282366920938463000000000000000000000 ----- cell bignum_to_string(cell x); --------------------------- bignum_to_string() will return a string object containing the decimal representation of the given bignum integer. The string will be allocated in the vector pool, so it is safe to convert /really/ big integers. ===== REAL NUMBER ARITHMETICS ================================== All real number operations except those with a Real_ or S9_ prefix (capital first letter) accept bignum operands and convert them to real numbers silently. Of course, this may cause a loss of precision when large bignums are involved in a computation. When /both/ operands of a real number operation are bignums, the function will perform a precise bignum computation instead (except for real_divide(), which will always perform a real number division). Note that S9core real numbers are base-10 (ten), so 1/2, 1/4, 1/5, 1/8 have exact results, but 1/3, 1/6, 1/7, and 1/9 do not. ----- Epsilon -------------------------------------------------- Epsilon (e) is a very small number: 10^-(S9_MANTISSA_SIZE+1). By all practical means, two numbers /a/ and /b/ should be considered to be equal, if their difference is not greater than /e/, i.e. |a-b|<=e. Of course, much smaller numbers can be expressed /and ordered/ by S9core (using real_less_p()), but the difference between two very small numbers becomes insignificant as it approaches /e/. This is particularly important when computing converging series. Here the precision cannot increase any further when the difference between the current guess x_i and previous guess x_i-1 drops below /e/. So the computation has reached a fixed point when |x_i - x_i-1| <= e. Technically, the value of Epsilon is chosen in such a way that its number of fractional digits is one more than the mantissa size, so it cannot represent an /exact/ difference between /any/ two exact real numbers. For example (given a mantissa size of 9 digits, 0.999999999 + 0.000000001 = 1.0 but 0.999999999 + 0.0000000001 = 0.999999999 In this example, the smaller value in the second equation would be equal to Epsilon. ----- Real_flags(x) -------------------------------------------- ----- Real_exponent(x) ----------------------------------------- ----- Real_mantissa(x) ----------------------------------------- ----- Real_negative_flag(x) ------------------------------------ The Real_mantissa() and Real_exponent() macros are just more efficient versions of the real_mantissa() and real_exponent() functions. Unlike their function counterparts, they accept real number operands exclusively. Real_flags() is described in the section on tagged types. Real_negative_flag() extracts the "negative sign" flag from the flags field of the given real number. **************************************************************** Note: Real_mantissa() returns a chain of integer segments without a type tag! **************************************************************** ----- Real_zero_p(x) ------------------------------------------- ----- Real_negative_p(x) --------------------------------------- ----- Real_positive_p(x) --------------------------------------- These predicate macros test whether the given real number is zero, negative, or positive, respectively. ----- Real_negate(a) ------------------------------------------- This macro negates the given real number (returning a new real number object). **************************************************************** Real_negate() does not protect its argument! **************************************************************** ----- cell real_abs(cell a); ----------------------------------- The real_abs() function returns the magnitude (absolute value) of its argument (the original value with a positive sign). ----- cell real_add(cell a, cell b); --------------------------- This function returns the sum of its arguments. **************************************************************** When the arguments /a/ and /b/ differ by /n/ orders of magnitude, where n>=S9_MANTISSA_SIZE, then the sum will be equal to the larger of the two arguments. E.g. (given a mantissa size of 9): 1000000000.0 + 9.0 = 1000000000.0" because the result (1000000009) would not fit in a mantissa. Even with values that overlap only partially, the result will be truncated, resulting in loss of precision. **************************************************************** This is not a bug, but an inherent property of floating point arithmetics. ----- cell real_divide(cell x, cell a, cell b); ---------------- This function returns the quotient /a/b/. Loss of precision may occur, e.g.: 1.0 / 3 * 3 = 0.999999999" (given a mantissa size of 9). The function /always/ performs a real number division, even if both arguments are integers. ----- int real_equal_p(cell a, cell b); ------------------------ The real_equal_p() predicate succeeds, if its arguments are equal. In S9core, two real numbers are equal, if they look equal when printed with print_real(). However, the result of a real number operation may not be equal to a specific real number, even if expected. For instance, 1.0 / 3 * 3 =/= 1.0 Generally, equality of real numbers implemented using a floating point representation should be considered with care. This applies not only to the S9core operations, but even to common hardware implementations of real numbers. See also: Epsilon ----- cell real_floor(cell x); --------------------------------- ----- cell real_trunc(cell x); --------------------------------- ----- cell real_ceil(cell x); ---------------------------------- These functions round the given real number as shown in figure 2. round function toward sample rounded ---------- ------ ------ ------- real_floor -inf 1.5 1.0 -1.5 -2.0 -------------------------------- real_trunc 0 1.5 1.0 -1.5 -1.0 -------------------------------- real_ceil +inf 1.5 2.0 -1.5 -1.0 -------------------------------- Fig 2. Rounding ----- cell real_integer_p(cell x); ----------------------------- This predicate succeeds, if the given number is an integer, i.e. has a fractional part of 0. This is trivially true for bignum integers. ----- int real_less_p(cell a, cell b); ------------------------- This predicate succeeds, if aâ$ñù±âÁÛ’Ñ Ø îÛè Šíø×m‰8(–·—Í#íÁ$¸l É‚¢ä·%ÁÊ`·#ä‚hñíÈä‚èªÛ|tAt¹í6©t.ˆ^D/ˆ½ypA´ù6„]X?7ñÛtA4U´4áZÒÍbK e0A—&\ãçÇG,MìǃãÅK O!–&gFó5?²t´'å¥ÈÜ\šÝ¾4Açëý¯Ô’ÄtoàÈ–¿pGdN³u³«_’`3‡:êYÿ³$™kw}¶ðs–&ߪ´Ã%Éœ’Þ°ò'2¯—"P8\’Ì´ §ógpâ;!,›Zœ(XÕ’dÚ?\°ý:ØX%—/E,”Îûê@M( ¤bXŠŠ™z½Rÿ±Í²1Ì\N,Ë.÷:—"ÀœÆÙ§Á£K™!p•úËâ²/Ej3frÖŸHp)réZÿ’Å9ùö#R›ÉäÍ.µq5EûH¡íåìc[ &úö$ ó6 ‰+ü¡·0,Ã,EâüäO¡ÅÜ–ç#ÌWÝLáâ„Pú~¬ânÁê°gS}Iª— ÖMr/Éß‘¹€1õ§à‹“©*ƾõtÊòGÓmÉ×Z/ÑÁ¡Ap_§àˆ7T׊-Nl¨/S˜ m˜r—·y߶/EòERSF[öåŽó×cy‹ãS¥çUø"î¦)›— ¦EÉ0nò–T³ÖÖîÝ7>bBéEÉê™,Ü I®çð`ÂO¢/ËPœËGŠ4Àî+|ý"¤ŠÃ[ž5/«xmÏKBÔââRÄášžvóJhà)Ç{6ïùüµe¸·\pcÁ° ž‹x•;­uYׇþ²ßsS¡ÅGÎñÏünÍÀ=‡Ž©õ. p»ñSžÈÁy ³‰dûpÌsïA;µ9‚¬Á½$›_Z1^’¯¼}ox °¿xkÀ2áûh® å%”Ò ÆǼ§¹X)L^Ë ¼ÝÒÁ‘T1/™TÚaÀ7@¾Ê¤ùö Âד;óÀÍKt›Š£àí$SÉƆ'é_{É3üןÊÝ|©X†¹Öz Û`û{Ò._ÆlŽ=ÅŠN9=Äuû^¯ÂïéCïã^bt="G-|ÃXª®×ßFGÚó~Ÿã["ÙUrÔÎGn¤ø Ôjk1/±±‰M»H>âî´s{Èa“ïÝóï}v(Mç!¸q$©1ü7.B—*@ÎJü¤:ssbÑ{Ø7²¥1ªš/ú}\è”Kü%ÂèG¦|Ua ŠâÄïà*Ì—ã«*ˆ^é¦ LžÀ-²¾å©rö˜Ït{§p,›ÜæËرF1ל É>û™ŸZý]œA#/B¶yóÏäu!–ýš-<©ì[–±Íß üà%Áww›â~ŸÌ= œÑŠÁ;ƒ­5æ%Z›ÌGês’ûûfÈeѣܸÇrí¤dªÿPPY4owé%l¯iÅoú»aL›Â¹óLôÁ2º pm0±1#9)ù3ëÎSí(à.³B×±µŽ. À¦ç˨Ùë¯ÔpÝ=Š[ »,Ù]ê^<¦wyu—,fûìý“ëG£iîŧºb¬IÖM ʂ슉‘dͺòØ¢Ÿz«ôRë÷lRB¹€d®‰ ÓÌÎU¯¹­ìQ`q°¼^Þ h¼Õ‚ë"Â2¥3µî¸ñ6`¹Õ9SÛ}¸:3©1oÙtJ¡VÍê,ã÷îÆáWàf~fm$×&9ô1&ü˜0T=›ÊW}+þŒû$Ë“jh< “‰¤{J[–8;#$2ÑCž×Ë,Â’_Éß°€Œ¸tåØ †5UÞ½á nORµ†yü•c ÈÓ»G-òÀ|N°jE¼wÕ~ÃA@íšö°Ÿ©;ƒ ³"ÔLj|ËQ uäÖîº$ÏáĽúƒ$¥tI-_—#Oõ“8ȱûö¬“ÐÕ«·®Åœ&T*u_k}¤?h þGL’‰5yrœ 'O8ßU.è0ÍÛÁ¸ºÄDb|Wþ 6nÙ®/Î3- ÿSWLi~ë 9šÄÜêĸK¥Æm_—Z…†`’¿õ¬ž‘àkâo…ÃG™á“´Ö³A& ¾û¦>KpæFpYr.êÛåŘ/¨&/¯1yn—´÷ÛØïh/åvt,(þTî˜äñ]˜7ŒäT|©óLc.`³ªŽG¾h "Œ#Ç\^Gø¶Õú¦^¯ûñ—IÜI¸CËäØr/DÑ™ Úe2—2Tty‰)û­¦Oö=ÇÄ€–¡Ò ’uÁd*þÍäWQð Æßg\gÉA½ƒQt¿¶º5*˜Pª´K½²Êrˆ¸v˜­‚K¢;ý&Z‹Ö¢Jªy·&$L#ÑüçŒ6¸{€é>ø~¾ªsŠW¹JbO°8 ²p¨Î;aè:É·ê0¦óôHpYúvRe¢•žñ"?LƒÿðAîSÜ^RTÞðmzÆ': œ±õûZ(ÔK†$ÿ¾ÿKÛøäøOÌöª—D×D0ÉÙ*§¢,$7 ˜þ ýÜZêíýÞÊø%k%I/‰ mp*ùxÝBá:¸hrÂnÅhªõœä<ŽÙªÅù¡Îª rj€%Žqו3-‡¸5ò}—¯{ªÌ¬ÀìT¤d(Êç“BÊ((5¦N¨…ÜŽ4”U`†Û&<»*V“‘»S›‚HC߃%Ñ#&äB­þ.Œêa†Ý÷rýšb;¸-ê©oÚšNEUÕi—Do´-›ê©ˆµ)´¯Ü€… ˆÉQ8«ÇÆ´m"ˆ¸Ê-Tå÷6ûubw™\ƒªµ0Æ5 ®å®ñSýG¡ ºÂã £èâÛgC$­59qŒ*Òtp[’Ë¥¨1×DH ð.c<Ñ÷©EdIÄ[´lùÄ´KÝåK«3µêœ"<ˆ˜am°…g^“4u2¡]x O[§ÀÑÁ¦%Ûø¯„p:„u˜ˆ‹cHñ˜µ¯®¦Ð©/Á¤KÛ³Éò½‹AÄ¢(Ð?Þ“¤“©;ÓŒÃCžÐý ´j´1¼ÛUÕD®ÐQtS1ù TÏ”¢ƒë˜ÍÎãËM%ÐöÚN×·Ÿ§BÀU{\E {Ž=ÌD€æÚDkwÀü‹½&u7, {ûÈx,FÂr‘ðw옫pv_©#™v3iŽAz©`å eˆÂ!ÛqI:Ž¨1Úì}k<Î-{'Oç#Q;ñù„kÚ3˜Ymuf.Ï»™8…Á3Ý Ž&ÀÝc!Ñ® B_ÂE4K8 £¥yfæ8Y¦ˆynjáƯ¬Šbl£ÎG«TöVnùA1ÂnɃZtL|g´ÙdJ…5RõZ‚ 3;V9ÞØ¡š¬˜WŸÏàzÿó’`%ø<„ÃïÿdL²}Siir9¼OüœýYÖ…¯ÃQn¼íéJ{Î8?Sô„æhÖ˜#•ë1—ã>”ûÄÂÁG²ä—ÎÖ‚Å”²]Ô³ûø| ×ù2|z ñªrƒŽ¶ÞÔ³ì\»ßüI-—*úðº­IóÉ”ÒUS‰JqgÏZBR±ï:ÃpâÓQ½þ.sîg·ÀxÉ}„éÝö•’̈ÞFTÉÖ<烩®“%tË;fÁù{آ݇[Grj㸮Ѥ )Ä\óŠ/p`-ƒZ¼~&^`µS\,J¿Rûù±8`v˜¸Í|&²’G6'è½] †£ŽY;{ñ!1»ì…š´< Ìš“/•Jç\2’a€M{“µd—»¤r«õüà›P]Jãcš`—Äö,º6„Ï#›rBYKL¾Õù×]ý©Ý §7$‡5„´œÉÿe„©›Wc“Ì ©¨%r:ΔEvu\Œ†ÆóøúU¦ ;4ݵñ\î]1îOÑy}ŒÐoŒRKk ìàþ*Ž\FÁÙƒ+N>—]všþ0Zo~7ÓŒŠç‘.R†l¿Ϋλ]†“ØÞìóNæþåÝ+`lL9–!Ekæ÷õSì²Sç O>°¿rèÙ¶2 .ìI>&UŒw=PjM8Ü”£BŽÏ#MÊz≃û÷3{’ ±ñ„Ïk“Ü_Tp«­ U­ Y§œ—1Ñh7Ô³ôÙaêÙuGB~ y¦ê@NõpWò½Ž¨ÁpØ]sÉ6›ÍôÂöøYíxFî«RD³ÞôUÍç#Ý;¹û𶟛P[ÌŹ©Pã!ˆ`ê ¬‘ÝðûªñÝù]‰xÕ´±_ëHï¹ñÀ¶îõU\0ôÉqóš•X#¼VRÚ²®\ ïMéóû/ŸrW[ÃÖß® C;_Ãú†>½cÄ¥ØP½¯<â€ÔpþŠ˜¯ú†%éøìûKî:Ý“‚Í%úeâŽNìTûàþ®¨2•ñœ»1þQiDZ(v]vZJ¦„Šæfl0âi ØÁȨ¾eX—êEnàËÏ«0\þ>—Jºñ¤ÑØfÉ©úõTØ›OaïµÖŒß]е;\]»Žß\¥ètOá yà¹'º"Ë·½Á¸gI^ì½SeѦ-²?nIëÙщ]ǧ²2µ¯s„} ;ùftù¤ÛêœÓ“#Ý{1v²2þ^¸š÷"7^N|È*iÀšøPËx 1•ê_áûšòáþ7ª,°?þ·‡ëQ…c@ÄžO(%¹¡Ús$ŸÝÓTœ8´JŒÏ­…µ[@Œ•–ÝÏâŒê= Ì’ènÄ%øça &¤1Ï¿ÛfoèxM<›Š}R’ãRÄ–%e½†ÜÝš‰kŒvt$u×7R.•„”}L‰¡áîná,ÁoÆÉûQ­Ô*øÞÈ2§}²¦$6Ö¢ã}ê~æññÁ{³º²³]©»RG©Ø­(A¤Ö,S¿¿yÏy‰½ `CoLdäÍ+²<½È ß´•6„ŠÛ´ÕùCHˆ‹Ä¹ö£ ¦wu.wRâ‹u=ó }O3øæý½EUY&í!š.=#SÜ~:ëÚWlt×åsóʪØ?hošKqêgI|!­µ´GײÉV®¦ÙÜÿM§ícÒóŸ¨Tÿáý½g»"ŸÓgâ2JŠrj+X%ÊJ$[³8"ûÄ­ùؘ£({á¿ô/|ûNdF¯÷‰J/¹1xIáˆWµU€¢^¡eoxî.­þÖVuúÙ]¯K-kžlx0¿P<;\èWDG&´µã–zb„õÜÚÂcIJÉîJà¶q}‰¿XDN«”%Èu¢‘D¥®Æˆze™f 7ªêÞú¿jsè¶Õ¡»¹¹$eÚëééøŒŽeÒ½áHy±(VwC»Y²©^áà|ld¿Rì¼ÂØR?¨[öp¦T ²uùIŸVý ußþ6ã&m̦:…wçñá42uiÛ§¦MÜTú«½)wï#+¿)=l–Håœ ÛßV§M鮳ôxªò±*Qssõnû3™N Oà:ÌÝPšá'C«\Ðg·UI )Æj¢Çèi«Ç2ßIþKßkIž[Úëŵy.XQS^«ð“óÙ¬Y8 ;QØ{¾Úòœgý×M˜»¦k›Š»œVe<†Ð×ûÒÏ{ž[õµ~ö9¹@¦ÅŸÈ¶Äž¶ÔVqaM{v%÷ÔNrmÄ,ÿÅWƒõŸà_a1šŠ¸^<j„'”Öäî儳’ ;²§¶ï$·¥0 uùŸâ?ƒ&AÛëäÍ¡Ó"4ÉNR UR«Õ3“ ¶8:S~?úâÛÿÚ~O).eô˶ÐyŸÅ‹± HÏÆs${“'eºïAùÀñº0î¸cg¦pÐ*Ò Ì/ÄtéÅ9Vþ†¬Rú ë!×F¢ðÄÞ³ýž› Ö–[ MÿJ6bK '»A&º¹J?%Tªz)O%ßPY³lüµ}Š;&w¿EN‰hB W%Ý£¥Xýìåu•ªŽ2a“˜¬+?±Õxn‚´ÆÈ ªJnLf~2J ÒigT#{ñzEI¼ÖC´éôôÒé™UX #R3ÆxŸÚô¥rÕø´õÖQ(¾ºkWDyît@‹ë¢™T.³{¿à{6±žÆšúnÙL5!Î"F Â[é¹UD‹ªEd„ÈCt_bo£:àöè·ŸŒÛ\ðbØé[WâI…Q¦T +ä›ÞäŽ]”8ÁÁåVâM훥%ü‹¸ 2ù$"¹·ÝSäâ+Ð@)[½ã¼pΞV/€Á²:rË­^eòÌp#M„ÒšPœ]ç=­xÎsÔ¾­hG9¹¯ƒaÅÍy8jtTyîQ¿š} m@ ÷ÇÞÓÈ9Okû¶Õ8"‹gÃÖ*îÿ’öÎ Îì/ö"Ñâ[1¾óJ`>¡c(åÓSj:µ1~çºßÆŽÿš kûóÛÐ~õoÆL8°ó …UÔÞ7éƪ–õíôí»N7†¸íÍ¢*O’®™pg×IýœÒ]˜R¯SŒ¢'<ÜaÌÜ.ýî§a¾Ù‚ÖÉŒ&‡!Ä%tÅÀdJ~˜jç-ÛŠûîÍ Ã¼çµ•gW’÷öÔLÊâÃ:};UÇAúæoòìÄ)úó’V»¯:ü;#EÊdû;“½1ôyà…¤£Z^ÒÖ¥­-påÛ©i™Î =‚ «äêÓü¤¨l—ö»ò H¡óGÞÊöú°çy´ËW|ô*8šql“ÞÞÜ[ší™v}Ǹ*,ç”[Áni6ß]ºÝ3ItFàoã4?±›Ž8òXq Fl– ¾ìÜîm {ùOxP„Óü„(Ðq[ ‘[…Õ¡eÝ뽤…Yù‘H3fâ%7’|rà ícZÉ%¡¡ ²LôV//iàzåÑbw¼„‰èa–Ÿ\«HGÓóó« hÂ4…æWÒ3Ý× ^ÂP[¿L‡Ñ'/áÒ¦·å­ìa&S¾® ¥é¨\ÿø/ÙǵØÖµcU˜[?%¾éû¾ƒÅÛMˆèš‘—<€[Yu¼²+c”²®þÎOäñƒ^ÁGXLaÕ¼/–ê7@')îõ#?ÓÛ'"·fó‘ö$‹yõžös#À¤ÛÿT*¶½Ëˆ—XySQá„D…ŽRy¤úðÉ'¾(”«j– mà% fHÊ’0ŒÜø*£YqÍUÍüa¢ÑXøÃÒλS ê+ê¹ügþo´.°'ψX*ËÉG È3FV&Kâš™¥ÐÿåÅYÐuÊï™ÎåK¥•@¯ª•Zƒ¤8¡DÇ}¾(#“¶Ò]|_oÆ ¨¾Èpu…¤t_ùa<ã'ƒ¼ý8.’ñ’òZ­ tf<þ~!ªñØ*6rP¼Dýºv@%/1‘Ž5Ôý·âLþ»‡Nsþ¡Uç×I4|©dfòŸ³1“‰/× Ç÷úÉÍÚó×X´ô(ÎG^¯e¤U(®ç<ëR²ý·5),áKœÆL*B½àêM6vå£SËY|zÍ‹~ÒL©>còE›0¾T†{êòñ¢ªœ,´+Äþ¨æ¯w%Á×Ì‹r>¢6^0SX‡^S‹Ë³?H`*v&r»S1oëwÚh2…°S.ÓMÚhôÇIž}„mtt|äBœµˆŒ‘@ìa×qûß_TÆŒÔOá#ÝåÓ /ŒYå$ÊÏ%û¿T²üh£Áœ©<„<µ-E-gÈXkJ Ĺz Í2¡sNg!°´ÖíÙ*—âÉø¤êë“asö³vT«Çbù2fÀòX©¨+¸9/9B qˆÞl‚-1És÷¬‹ë<"­þuýÁËqg§”ÕÜÌlâ#„4Gm±°ÉÑ=Xù?:猶¿ÂÍÃŒ‘”¯£dQz‹\öaƒæÏÌŽ$ûå_¸XI®ÍH‰!òv‡>E6óTÃL< b3_·dÕ¯ÖǨÑÄåúM¹Ž/dâf”N£ùÝd¾všXmD ›¸‘+‰#3­M X²nüMÈÛ”Šó}¢²L5ÿ]{EØå™v N #Œâ#q组]E$.Õâwδõ÷´q ¥>’0Ú%äFÊä«zÖÍÌtôߟ¨¸[÷ðHµˆ:µ¥°bÔAD¼<óX¿{Ýô_µzä.>5J¯°Ô:Ù8cg»s,ךúúMŠFùÈþ†´t“#|`èÛql’û“>ü4ïcÍd–Ñ=¾UV*-^ë˜%ÄÇQç2>RaÞó ™ÉéK]š%0h/&ôy<äœ^’©Tp½@¹Qp¸zöçKO²Æ)*g”˜¢Ü‘$ Îà˜¤§y–üˆM©—DŽ¦ò\”_ù$PçbÅ);‡žŸ‰ÃÚ$´c|D#”Eb@õŸ‹ú~ 3KP¼0kÒó#Ð…„Ì+)Ž7qË2‹öÈg¯?iÔ[D´Ÿ‡Ð'KÎf²@1îk„h–”áçZ­JØÅGš„6}Ði›Ý¬²sfit¤Ê™]¿‡ËaÌnJÜŒàclKãLd¼lä¦4-ËCî1;q€ã¢…‰{êgŸ&0¸€ Î…dâ®ÉRŽ|ÿ´œÐÎÞk7\¼œ‚oáÉë=¯½£áÅæS³?5ê¾re$¾ªn‡‹x«¾s£¦W¶ãüìO º»ß_¥qUdðj/‰Tgh®Í««u¸7ÞD£<Äí}â[7^´ŸIÏ6Îh­>£T.$¸ÅýËæU6XÙôYrÿ¼FY›<©xÿX•t8þø“«7Í„Ø¥©Ó¶ö&Ö±®$*k<9›s;FCázš½—xë­ƒ«r¼|rv ¢uûÇ׬¹g±Tè£΢GŸúhö‰Å!tÙž½1ÈÆfï£/–¨ÇÖ´¼¤Eˆ«\Ž÷ÂsžžLó=é"Ê]…›Øצøˆçë.y2Xlƒ ºAæ½ó`–M(êœ''çý4ñÍ$ «a÷eN!‡öf"ž»³Åž›JžW §æ? þßħ!¿ûà®àùºÃû§GPœ]¦êäs¾G/gHŽ‡xnúãï/‹ICÄfïZ\ç‰*F…çÿ¶¦µVÍ/ Uìûå={˜9‚DØòO¯|§¤ ôÂ✜xÄð+Í'Þ&ADqÑZ Õ#¢ vb ÐÜ a÷¨Ä O¥îûÖOu¾*#…6æôôßg†SR´÷Œ²Õó1<Û.•9HÄwS}¿1eväy>y*-A©r ïA¾=ˆ(@Ÿ†„ë¸Հ˄_*ú^äRŽLã&¤~V9"@ž¡zîö ’b )ˆKÌ\Eqµ'WªÁ3ªƒ–=ÃEå“ ø˜b=•+ä‰ 2Dp7¢ùÚH«ä.Ð˨÷wYì]!\…®ÁÛ}ÿ¯W¿ˆc#æmÏ;áLûRÜnO:… =c£\䘧Csáñ1óz·û÷õõ€¬9u and (optionally) in your project and link against libs9core.a If you want to include the S9core files in your project, note that you can compile s9core with cc -DTEST -o s9core s9core.c to obtain an executable that will perform a quick self-test when called. It will not print anything when the test succeeds and print some diagnostic message and exit with a failure code otherwise. Feel free to include S9core in any project you like. It's in the public domain. ENJOY! s9/s9ext.h000644 001751 001751 00000001074 12750620645 012257 0ustar00nmhnmh000000 000000 /* * Scheme 9 from Empty Space, Refactored * By Nils M Holm, 2007-2016 * In the public domain * * Interface for extension procedures. */ #define BOL T_BOOLEAN #define CHR T_CHAR #define INP T_INPUT_PORT #define INT T_INTEGER #define LST T_LIST #define OUP T_OUTPUT_PORT #define PAI T_PAIR #define FUN T_FUNCTION #define REA T_REAL #define STR T_STRING #define SYM T_SYMBOL #define VEC T_VECTOR #define ___ T_ANY void add_primitives(char *name, S9_PRIM *p); cell error(char *msg, cell expr); cell integer_value(char *src, cell x); s9/util/rpp.c000644 001751 001751 00000013372 12425635676 012771 0ustar00nmhnmh000000 000000 /* * RPP -- ROFF Post-Processor * By Nils M Holm 1994 */ #include #include #include #include #define MYNAME "rpp" #define MAXLINE 1024 #define TMAC "util/rp_" #define PREFIX "rp_" #define ROMAN 0 #define BOLD 1 #define ITALIC 2 int o_asciify = 0, o_upcase = 0, o_htmlize = 0; char *o_prof = "profile"; char *inits, *bon, *boff, *uon, *uoff, *ion, *ioff; char *sBold, *eBold, *sItalics, *eItalics; int font = ROMAN; void error(msg, a1, a2) char *msg, *a1, *a2; { fprintf(stderr, "*** %s: ", MYNAME); fprintf(stderr, msg, a1, a2); fputc('\n', stderr); } int setfont(s, i, f) char *s; int f, i; { if (font == f) return(i); s[i] = 0; switch (font) { case ROMAN: break; case BOLD: strcat(s, eBold); break; case ITALIC: strcat(s, eItalics); break; } switch (f) { case ROMAN: break; case BOLD: strcat(s, sBold); break; case ITALIC: strcat(s, sItalics); break; } font = f; return(strlen(s)); } int copybuf(buf, i, c) char *buf; int i, c; { if (o_htmlize) { switch (c) { case '&': strcpy(&buf[i], "&"); return i+5; case '<': strcpy(&buf[i], "<"); return i+4; case '>': strcpy(&buf[i], ">"); return i+4; } } buf[i] = c; return i+1; } char *process(s) char *s; { static char obuf[MAXLINE]; int i, back; if (o_asciify) { for (back=i=0; *s; s++) if (*s == '\b' && i) { i--; back = 1; } else { obuf[i++] = (back && o_upcase && islower(*s)? toupper(*s): *s); back = 0; } obuf[i] = 0; return(obuf); } for (i=0; *s; s++) { if (*s == '\b' && i) { if (obuf[--i] == '_') { i = setfont(obuf, i, ITALIC); for (; *(s-1) == '_' && *s=='\b'; s += 3) i = copybuf(obuf, i, *(s+1)); } else { i = setfont(obuf, i, BOLD); for (; *(s-1) == *(s+1) && *s=='\b'; s += 3) i = copybuf(obuf, i, *(s+1)); } s -= 2; } else { i = setfont(obuf, i, ROMAN); i = copybuf(obuf, i, *s); } } setfont(obuf, i, ROMAN); obuf[i] = 0; return(obuf); } void rpp(file) char *file; { FILE *in; static char buf[MAXLINE]; char *obuf; if (file) { if ((in = fopen(file, "r")) == NULL) { error("no such file: `%s'", file, NULL); return; } } else in = stdin; fgets(buf, MAXLINE, in); while (!feof(in)) { obuf = process(buf); fputs(obuf, stdout); fgets(buf, MAXLINE, in); } if (file) fclose(in); } char *strsave(s) char *s; { char *new; if ((new = (char *) malloc(strlen(s)+1)) == NULL) { error("out of memory", NULL, NULL); error("aborting...", NULL, NULL); exit(-1); } strcpy(new, s); return(new); } int cval(c, r) int c, r; { char *digits; int i; digits = "0123456789abcdef"; c = (isupper(c)? tolower(c): c); for (i=0; i= 0; p++) { v = cval(*p, radix); c = v<0?c:(c*radix+v); } buf[i++] = c; } else buf[i++] = *p; } else buf[i++] = *p; buf[i] = 0; *arg = strsave(buf); } void readprofile() { char buf[MAXLINE]; FILE *pf; int lno = 0; if (o_asciify) return; inits = bon = boff = uon = uoff = ion = ioff = ""; sprintf(buf, "%s%s", TMAC, o_prof); if ((pf = fopen(buf, "r")) == NULL) { sprintf(buf, "%s%s", PREFIX, o_prof); if ((pf = fopen(buf, "r")) == NULL) { error("profile not found (%s) -- using ASCII-fy mode", buf, NULL); o_asciify = 1; return; } } fgets(buf, MAXLINE, pf); while (!feof(pf)) { ++lno; if (buf[0] == '\n' || buf[0] == '#') { fgets(buf, MAXLINE, pf); continue; } else if (!strncmp(buf, "init-string", 11)) set(&inits, buf, lno); else if (!strncmp(buf, "boldface-on", 11)) set(&bon, buf, lno); else if (!strncmp(buf, "boldface-off", 12)) set(&boff, buf, lno); else if (!strncmp(buf, "underline-on", 12)) set(&uon, buf, lno); else if (!strncmp(buf, "underline-off", 13)) set(&uoff, buf, lno); else if (!strncmp(buf, "italics-on", 10)) set(&ion, buf, lno); else if (!strncmp(buf, "italics-off", 11)) set(&ioff, buf, lno); else { sprintf(buf, "%d", lno); error("bad option in profile (line %s)", buf, NULL); } fgets(buf, MAXLINE, pf); } fclose(pf); sBold = bon; eBold = boff; sItalics = ion; eItalics = ioff; fputs(inits, stdout); if (!strcmp(o_prof, "html")) o_htmlize = 1; } void usage() { fprintf(stderr, "usage: %s [-acu] [-pprofile] [file ...]\n", MYNAME); exit(1); } int main(argc, argv) int argc; char **argv; { int i, p; for (p=1; p= argc) rpp(NULL); else while (p boldface-off underline-on underline-off italics-on italics-off s9/util/test.scm000644 001751 001751 00000174541 12617640200 013473 0ustar00nmhnmh000000 000000 ; Scheme 9 from Empty Space ; Test Suite ; By Nils M Holm, 2007-2012 ; This is a comment #| This is a block comment |# #| Nested #| block |# comment |# #| Nested #| multi-line |# block comment |# #|#|#||#|# nonsense |# #| #|#||#|# more nonsense #|## |||#|# (define testfile "__testfile__") (if (file-exists? testfile) (error (string-append "Please delete the file \"" testfile "\" before running this test."))) (define Errors 0) (define (void) (if #f #f)) (define (seq) (let ((n 1)) (lambda () (let ((x n)) (set! n (+ 1 n)) x)))) (define (fail expr result expected) (display "test failed: ") (write expr) (newline) (display "got result: ") (write result) (newline) (display "expected: ") (write expected) (newline) (set! Errors (+ 1 Errors))) (define (test3 expr result expected) ; (write expr) (display " => ") (write result) (newline) (if (not (equal? result expected)) (fail expr result expected))) (define-syntax (test form expected) `(test3 ',form ,form ,expected)) ; --- syntax --- ; symbols (test 'x 'x) (test 'mississippi 'mississippi) (test 'MIssissiPPi 'mississippi) (test '!$%&*+-./^_ '!$%&*+-./^_) ; booleans (test #t #t) (test #f #f) ; chars (test #\x #\x) (test #\C #\C) (test #\( #\() (test #\) #\)) (test #\; #\;) (test #\space #\space) (test #\newline #\newline) ; strings (test "test" "test") (test "TeSt" "TeSt") (test "TEST" "TEST") (test "hello, world!" "hello, world!") (test "\"hello, world!\"" "\"hello, world!\"") (test "a\\/b" "a\\/b") (test "(((;)))" "(((;)))") ; pairs -- erm, well (test '() '()) (test '(a b c) '(a b c)) (test '(a (b) c) '(a (b) c)) (test '(((((x))))) '(((((x)))))) (test '((caar . cdar) . (cadr . cddr)) '((caar . cdar) . (cadr . cddr))) (test '[] '()) (test '[a b c] '(a b c)) (test '(a [b] c) '(a (b) c)) (test '[a (b) c] '(a (b) c)) (test '[a [b] c] '(a (b) c)) (test '(((((x))))) '(((((x)))))) (test '([([(x)])]) '(((((x)))))) (test '[([([x])])] '(((((x)))))) (test '[[[[[x]]]]] '(((((x)))))) (test '([caar . cdar] . [cadr . cddr]) '((caar . cdar) . (cadr . cddr))) ; vectors (test '#() '#()) (test '#(a b c) '#(a b c)) (test '#(a (b) c) '#(a (b) c)) (test '#(((((x))))) '#(((((x)))))) (test '#((caar cadar) (caadr cadadr)) '#((caar cadar) (caadr cadadr))) (test '#(#(a b c) #(d e f)) '#(#(a b c) #(d e f))) (test '#(#(#(#(#(x))))) '#(#(#(#(#(x)))))) ; numbers -- integers (test 0 0) (test 1 1) (test 1234567 1234567) (test -0 0) (test -1 -1) (test -1234567 -1234567) (test 123456789012345678901234567890 123456789012345678901234567890) (test -123456789012345678901234567890 -123456789012345678901234567890) (test #b10101010100101010101 698709) (test #b+10101010100101010101 +698709) (test #b-10101010100101010101 -698709) (test #d1234567890987654321 1234567890987654321) (test #d+1234567890987654321 +1234567890987654321) (test #d-1234567890987654321 -1234567890987654321) (test #o123456707654321 5744369817809) (test #o+123456707654321 +5744369817809) (test #o-123456707654321 -5744369817809) (test #x123456789abcdef0fedcba98765432 94522879700260683132212139638805554) (test #x+123456789abcdef0fedcba98765432 +94522879700260683132212139638805554) (test #x-123456789abcdef0fedcba98765432 -94522879700260683132212139638805554) ; and (test (and) #t) (test (and #f) #f) (test (and #f #f) #f) (test (and #f #t) #f) (test (and #t #f) #f) (test (and #t #t) #t) (test (and 1 2 3) 3) (test (and #f 2 3) #f) (test (and 1 #f 3) #f) (test (and 1 2 #f) #f) (test (and 'foo) 'foo) (test (and #t) #t) (test (and 1) 1) (test (and #\x) #\x) (test (and "x") "x") (test (and '(x)) '(x)) (test (and '()) '()) (test (and '#(x)) '#(x)) (test (and (lambda (x) x) #t) #t) ; begin (test (begin 1) 1) (test (begin 1 "2") "2") (test (begin 1 "2" #\3) #\3) (test (let ((x (seq)) (y 0)) (begin (set! y (- y (x))) (set! y (- y (x))) (set! y (- y (x)))) y) -6) ; cond (test (cond) (void)) (test (cond (#t 1)) 1) (test (cond (1 1)) 1) (test (cond ('x 1)) 1) (test (cond (#\x 1)) 1) (test (cond ("x" 1)) 1) (test (cond ('(a b c) 1)) 1) (test (cond ('() 1)) 1) (test (cond (#(1 2 3) 1)) 1) (test (cond (#f 1)) (void)) (test (cond (#f 1) (#t 2)) 2) (test (cond (#f 1) (else 2)) 2) (test (cond (else 2)) 2) (test (cond (#t 1 2 3)) 3) (test (cond (else 1 2 3)) 3) (test (cond (#f (#f))) (void)) (test (cond (#f)) (void)) (test (cond (#f) (#t)) #t) (test (cond (1 => list)) '(1)) (test (cond (#f => list) (#t => list)) '(#t)) (test (cond (1)) 1) (test (cond ('foo)) 'foo) (test (cond ('())) '()) (test (cond ('(()))) '(())) ; define (define x 'foo) (test (let () (define x 1) x) 1) (test ((lambda () (define x 0) x)) 0) (test (begin ((lambda () (define x 0) x)) x) 'foo) (test (begin (let () (define x 0) x) x) 'foo) (test (begin (let () (define x 0) x)) 0) (test (let () (letrec () (define x 0) x) x) 'foo) (test (let () (letrec () (define x 0) x)) 0) (test (let () (define (f) 1) (f)) 1) (test (let () (define (f x) x) (f 1)) 1) (test (let () (define (f x y) x) (f 1 2)) 1) (test (let () (define (f x y) y) (f 1 2)) 2) (test (let () (define (f . x) x) (f)) '()) (test (let () (define (f . x) x) (f 1)) '(1)) (test (let () (define (f . x) x) (f 1 2)) '(1 2)) (test (let () (define (f x . y) y) (f 1 2)) '(2)) (test (let () (define f (lambda () 1)) (f)) 1) (test (let () (define f (lambda (x) x)) (f 1)) 1) (test (let () (define f (lambda (x y) x)) (f 1 2)) 1) (test (let () (define f (lambda (x y) y)) (f 1 2)) 2) (test (let () (define f (lambda x x)) (f)) '()) (test (let () (define f (lambda x x)) (f 1)) '(1)) (test (let () (define f (lambda x x)) (f 1 2)) '(1 2)) (test (let () (define f (lambda (x . y) y)) (f 1 2)) '(2)) (test ((lambda () (define (e x) (or (zero? x) (o (- x 1)))) (define (o x) (if (zero? x) #f (e (- x 1)))) (list (o 5) (e 5)))) '(#t #f)) ; if (test (if #f #f) (void)) (test (if #t 1) 1) (test (if 1 1) 1) (test (if 'a 1) 1) (test (if #\a 1) 1) (test (if "a" 1) 1) (test (if '(1 2 3) 1) 1) (test (if '() 1) 1) (test (if '#(1 2 3) 1) 1) (test (if #t 1 2) 1) (test (if #f 1 2) 2) (test (if #f (#f)) (void)) ; lambda (test ((lambda () '())) '()) (test ((lambda (x) x) 1) 1) (test ((lambda (x y z) (list x y z)) 1 2 3) '(1 2 3)) (test (((lambda (x) (lambda (y) (cons x y))) 1) 2) '(1 . 2)) (test ((lambda (a . b) a) 'foo) 'foo) (test ((lambda (a . b) b) 'foo) '()) (test ((lambda (a . b) b) 'foo 'bar) '(bar)) (test ((lambda (a . b) b) 'foo 'bar 'baz) '(bar baz)) (test ((lambda (a b . c) a) 'foo 'bar) 'foo) (test ((lambda (a b . c) b) 'foo 'bar) 'bar) (test ((lambda (a b . c) c) 'foo 'bar) '()) (test ((lambda (a b . c) c) 'foo 'bar 'baz) '(baz)) (test ((lambda a a)) '()) (test ((lambda a a) 'foo) '(foo)) (test ((lambda a a) 'foo 'bar) '(foo bar)) (test ((lambda a a) 'foo 'bar 'baz) '(foo bar baz)) (test ((lambda (x) ((lambda () x))) 1) 1) (test ((lambda () 1 2 3)) 3) (test ((lambda (x) ((lambda () (set! x 1))) x) 0) 1) (define x 1) (define (g) x) (define (f0) (let ((x 0)) (set! x (g)) x)) (define (f1) (let ((x 0)) (let () (set! x (g)) x))) (test (f0) 1) (test (f1) 1) (define (f2) (let ((x 2)) (let ((r (g))) r))) (test (f2) 1) ; let (test (let () 1) 1) (test (let () 1 2 3) 3) (test (let ((x 1)) x) 1) (test (let ((x 1) (y 2) (z 3)) (list x y z)) '(1 2 3)) (test (let ((x 0)) (let ((x 1) (y (* x 1))) y)) 0) (test (let ((x 0)) (let ((x 1)) (let ((y (* x 1))) y))) 1) ; letrec (test (letrec () 1) 1) (test (letrec () 1 2 3) 3) (test (letrec ((x 1)) x) 1) (test (letrec ((x 1) (y 2) (z 3)) (list x y z)) '(1 2 3)) (test (letrec ((even-p (lambda (x) (or (null? x) (odd-p (cdr x))))) (odd-p (lambda (x) (if (null? x) #f (even-p (cdr x)))))) (list (odd-p '(i i i i i)) (even-p '(i i i i i)))) '(#t #f)) (test (let* () 1) 1) (test (let* () 1 2 3) 3) (test (let* ((x 'first)) x) 'first) (test (let* ((x 'first) (y 'second) (z 'third)) (list x y z)) '(first second third)) (test (let* ((x 0)) (let* ((x 1) (y (* x 5))) y)) 5) (test (let* ((x 3) (y (cons 2 x)) (z (cons 1 y))) z) '(1 2 . 3)) (test (let* ((x 3) (x (cons 2 x)) (x (cons 1 x))) x) '(1 2 . 3)) ; or (test (or) #f) (test (or #f) #f) (test (or #f #f) #f) (test (or #f #t) #t) (test (or #t #f) #t) (test (or #t #t) #t) (test (or 1 2 3) 1) (test (or #f 2 3) 2) (test (or 1 #f 3) 1) (test (or #f #f 3) 3) (test (or 'foo) 'foo) (test (or #t) #t) (test (or 1) 1) (test (or #\x) #\x) (test (or "x") "x") (test (or '(x)) '(x)) (test (or '()) '()) (test (or '#(x)) '#(x)) ; quote (test (quote foo) 'foo) (test (quote quote) 'quote) (test (quote #t) #t) (test (quote 1) 1) (test (quote #\X) #\X) (test (quote "abc") "abc") (test (quote ()) '()) (test (quote (1 2 3)) '(1 2 3)) (test (quote #(1 2 3)) '#(1 2 3)) (test (quote (lambda (x) x)) '(lambda (x) x)) (test '1 '1) (test ''1 ''1) (test '''1 '''1) (test '#f #f) (test '1 1) (test '#\b #\b) (test '"abc" "abc") ; --- setters --- (define x 0) (test (begin (set! x 1) x) 1) (test (begin ((lambda (x) (set! x 0)) 'void) x) 1) (test (begin (let ((x 'void)) (set! x 0)) x) 1) (test (begin (let* ((x 'void)) (set! x 0)) x) 1) (test (begin (letrec ((x 'void)) (set! x 0)) x) 1) (test (begin (set! x 2) x) 2) (define p (cons 1 2)) (test (begin (set-car! p 'a) p) '(a . 2)) (test (begin (set-cdr! p 'b) p) '(a . b)) ; --- type predicates --- (test (boolean? #f) #t) (test (boolean? #\c) #f) (test (boolean? 1) #f) (test (boolean? '(pair)) #f) (test (boolean? (lambda () #f)) #f) (test (boolean? "string") #f) (test (boolean? 'symbol) #f) (test (boolean? '#(vector)) #f) (test (boolean? (current-input-port)) #f) (test (boolean? (current-output-port)) #f) (test (boolean? let) #f) (test (char? #f) #f) (test (char? #\c) #t) (test (char? 1) #f) (test (char? '(pair)) #f) (test (char? (lambda () #f)) #f) (test (char? "string") #f) (test (char? 'symbol) #f) (test (char? '#(vector)) #f) (test (char? (current-input-port)) #f) (test (char? (current-output-port)) #f) (test (char? let) #f) (test (input-port? #f) #f) (test (input-port? #\c) #f) (test (input-port? 1) #f) (test (input-port? '(pair)) #f) (test (input-port? (lambda () #f)) #f) (test (input-port? "string") #f) (test (input-port? 'symbol) #f) (test (input-port? '#(vector)) #f) (test (input-port? (current-input-port)) #t) (test (input-port? (current-output-port)) #f) (test (input-port? let) #f) (test (integer? #f) #f) (test (integer? #\c) #f) (test (integer? 1) #t) (test (integer? '(pair)) #f) (test (integer? (lambda () #f)) #f) (test (integer? "string") #f) (test (integer? 'symbol) #f) (test (integer? '#(vector)) #f) (test (integer? (current-input-port)) #f) (test (integer? (current-output-port)) #f) (test (integer? let) #f) (test (number? #f) #f) (test (number? #\c) #f) (test (number? 1) #t) (test (number? '(pair)) #f) (test (number? (lambda () #f)) #f) (test (number? "string") #f) (test (number? 'symbol) #f) (test (number? '#(vector)) #f) (test (number? (current-input-port)) #f) (test (number? (current-output-port)) #f) (test (number? let) #f) (test (output-port? #f) #f) (test (output-port? #\c) #f) (test (output-port? 1) #f) (test (output-port? '(pair)) #f) (test (output-port? (lambda () #f)) #f) (test (output-port? "string") #f) (test (output-port? 'symbol) #f) (test (output-port? '#(vector)) #f) (test (output-port? (current-input-port)) #f) (test (output-port? (current-output-port)) #t) (test (output-port? let) #f) (test (pair? #f) #f) (test (pair? #\c) #f) (test (pair? 1) #f) (test (pair? '(pair)) #t) (test (pair? (lambda () #f)) #f) (test (pair? "string") #f) (test (pair? 'symbol) #f) (test (pair? '#(vector)) #f) (test (pair? (current-input-port)) #f) (test (pair? (current-output-port)) #f) (test (pair? let) #f) (test (port? #f) #f) (test (port? #\c) #f) (test (port? 1) #f) (test (port? '(pair)) #f) (test (port? (lambda () #f)) #f) (test (port? "string") #f) (test (port? 'symbol) #f) (test (port? '#(vector)) #f) (test (port? (current-input-port)) #t) (test (port? (current-output-port)) #t) (test (port? let) #f) (test (procedure? #f) #f) (test (procedure? #\c) #f) (test (procedure? 1) #f) (test (procedure? '(procedure)) #f) (test (procedure? (lambda () #f)) #t) (test (procedure? "string") #f) (test (procedure? 'symbol) #f) (test (procedure? '#(vector)) #f) (test (procedure? (current-input-port)) #f) (test (procedure? (current-output-port)) #f) (test (procedure? let) #f) (test (string? #f) #f) (test (string? #\c) #f) (test (string? 1) #f) (test (string? '(pair)) #f) (test (string? (lambda () #f)) #f) (test (string? "string") #t) (test (string? 'symbol) #f) (test (string? '#(vector)) #f) (test (string? (current-input-port)) #f) (test (string? (current-output-port)) #f) (test (string? let) #f) (test (symbol? #f) #f) (test (symbol? #\c) #f) (test (symbol? 1) #f) (test (symbol? '(pair)) #f) (test (symbol? (lambda () #f)) #f) (test (symbol? "string") #f) (test (symbol? 'symbol) #t) (test (symbol? '#(vector)) #f) (test (symbol? (current-input-port)) #f) (test (symbol? (current-output-port)) #f) (test (symbol? let) #f) (test (vector? #f) #f) (test (vector? #\c) #f) (test (vector? 1) #f) (test (vector? '(pair)) #f) (test (vector? (lambda () #f)) #f) (test (vector? "string") #f) (test (vector? 'symbol) #f) (test (vector? '#(vector)) #t) (test (vector? (current-input-port)) #f) (test (vector? (current-output-port)) #f) (test (vector? let) #f) ; --- conversion procedures --- (test (char->integer #\A) 65) (test (char->integer #\z) 122) (test (char->integer #\newline) 10) (test (char->integer #\space) 32) (test (integer->char 65) #\A) (test (integer->char 122) #\z) (test (integer->char 10) #\newline) (test (integer->char 32) #\space) (test (list->string '(#\S #\t #\r #\i #\n #\g)) "String") (test (list->string '()) "") (test (list->vector '(#t foo 1 #\c "s" (1 2 3) #(u v))) '#(#t foo 1 #\c "s" (1 2 3) #(u v))) (test (list->vector '()) '#()) (test (string->list "String") '(#\S #\t #\r #\i #\n #\g)) (test (string->list "") '()) (test (string->symbol "foo") 'foo) (test (string->symbol "string->symbol") 'string->symbol) (test (symbol->string 'foo) "foo") (test (symbol->string 'symbol->string) "symbol->string") (test (symbol->string (string->symbol "miSSissiPPi")) "miSSissiPPi") (test (eq? (string->symbol "foo") 'foo) #t) (test (vector->list '#(#t foo 1 #\c "s" (1 2 3) #(u v))) '(#t foo 1 #\c "s" (1 2 3) #(u v))) (test (vector->list '#()) '()) ; --- more control --- (test (apply (lambda () 1) '()) 1) (test (apply car '((a . b))) 'a) (test (apply cdr '((a . b))) 'b) (test (apply cons '(1 2)) '(1 . 2)) (test (apply list '(1 2 3)) '(1 2 3)) (test (apply list 1 '(2 3)) '(1 2 3)) (test (apply list 1 2 '(3)) '(1 2 3)) (test (apply list 1 2 3 '()) '(1 2 3)) (test (call/cc (lambda (k) 'foo)) 'foo) (test (cons 'foo (call/cc (lambda (k) (k 'bar)))) '(foo . bar)) (test (cons 'foo (call/cc (lambda (k) (cons 'zzz (k 'bar))))) '(foo . bar)) (test (letrec ((x (call/cc (lambda (k) (cons 'a k))))) (let ((v (car x)) (k (cdr x))) (cond ((eq? v 'a) (k (cons 'b k))) ((eq? v 'b) (k (cons 'c k))) ((eq? v 'c) 'foo) (else #f)))) 'foo) ; Following CALL/CC tests by Al* Petrofsky (test (letrec ((x (call/cc (lambda (x) x)))) (if (procedure? x) (x 'foo) x)) 'foo) (test ((lambda (x) (if (pair? x) ((car x) (lambda () x)) (pair? (x)))) (call/cc list)) #t) ; Oops, broke it! ; ;(test (letrec ((x (call/cc list)) ; (y (call/cc list))) ; (cond ((procedure? x) (x (pair? y))) ; ((procedure? y) (y (pair? x))) ; ((call/cc (car x)) (call/cc (car y))) ; (else #f))) ; #t) (test (letrec ((x (call/cc (lambda (c) (list #t c))))) (if (car x) ((cadr x) (list #f (lambda () x))) (eq? x ((cadr x))))) #t) (test (case 'a ((a b) 'first) ((c d) 'second)) 'first) (test (case 'b ((a b) 'first) ((c d) 'second)) 'first) (test (case 'c ((a b) 'first) ((c d) 'second)) 'second) (test (case 'd ((a b) 'first) ((c d) 'second)) 'second) (test (case 'x ((a b) 'first) ((c d) 'second)) (void)) (test (case 'x ((a b) 'first) (else 'default)) 'default) (test (case 'd ((a) 'a) ((b) 'b) ((c) 'c) (else 'default)) 'default) (test (case 'c ((a) 'a) ((b) 'b) ((c) 'c) (else 'default)) 'c) (test (case 'b ((a) 'a) ((b) 'b) ((c) 'c) (else 'default)) 'b) (test (case 'a ((a) 'a) ((b) 'b) ((c) 'c) (else 'default)) 'a) (test (case 'x ((a) 'a) ((b) 'b) ((c) 'c) (else 'default)) 'default) (test (case 'x ((b) 'b) ((c) 'c) (else 'default)) 'default) (test (case 'x ((c) 'c) (else 'default)) 'default) (test (case 'x (else 'default)) 'default) (test (case 1 ((1) #t)) #t) (test (case #\c ((#\c) #t)) #t) (test (case 'x (else 1 2 3)) 3) (test (case 'x ((y) #f)) (void)) (test (do () (#t 123)) 123) (test (do () (#t)) (void)) (test (do ((i 1 (+ 1 i))) ((= i 10) i) i) 10) (test (do ((i 1 (+ 1 i)) (j 17)) ((= i 10) j) i) 17) (test (do ((i 1 (+ 1 i)) (j 2 (+ 2 j))) ((= i 10) j) i) 20) (test (do ((i 1 (+ 1 i)) (j 2 (+ 2 j))) ((= i 10) (* i j)) i) 200) (test (let ((j 1)) (do ((i 0 (+ 1 i))) ((= i 10) j) (set! j (+ j 3)))) 31) (test (do ((i 1 (+ 1 i)) (j 0)) ((= i 10) j) (set! j 1)) 1) (test (do ((i 1 (+ 1 i)) (j 0)) ((= i 10) j) 1 2 3 (set! j 1)) 1) (test (let ((a (list (list 'a) (list 'b) (list 'c)))) (for-each (lambda (x) (set-car! x 'x)) a) a) '((x) (x) (x))) (test (let ((a (list (list 'a) (list 'b) (list 'c)))) (for-each (lambda (x y) (set-car! x y)) a '(x y z)) a) '((x) (y) (z))) (define s (seq)) (begin (s) (void)) (define x (delay (s))) (test (list (force x) (force x) (force x)) '(2 2 2)) (test (map - '(1 2 3)) '(-1 -2 -3)) (test (map cons '(1 2 3) '(a b c)) '((1 . a) (2 . b) (3 . c))) (test (map list '(1 2 3) '(a b c) '(#\x #\y #\z)) '((1 a #\x) (2 b #\y) (3 c #\z))) ; --- quasiquotation --- (define x 'foo) (test `x 'x) (test `,x 'foo) (test `(1 2 3) '(1 2 3)) (test `(y ,x z) '(y foo z)) (test `(1 2 3 ,(list 4 5)) '(1 2 3 (4 5))) (test `(1 2 3 ,@(list 4 5)) '(1 2 3 4 5)) (test `#(y ,x z) '#(y foo z)) (test `#(1 2 3 ,(list 4 5)) '#(1 2 3 (4 5))) (test `#(1 2 3 ,@(list 4 5)) '#(1 2 3 4 5)) (test `(a b c (,x y z)) '(a b c (foo y z))) (test `(a b c (,x ,@(list 'y 'z))) '(a b c (foo y z))) (test `(+ 1 ,(* 2 `,(* 3 4))) '(+ 1 24)) (test `(+ 1 (car '(,@(memv 2 `,(list 1 (+ 1 1) 3))))) '(+ 1 (car '(2 3)))) ; --- lists --- (test (append '() '(a b c)) '(a b c)) (test (append '(a b c) '()) '(a b c)) (test (append '() '()) '()) (test (append) '()) (test (append '(a b)) '(a b)) (test (append '(a b) '(c d)) '(a b c d)) (test (append '(a b) '(c d) '(e f)) '(a b c d e f)) (test (append '(a b) 'c) '(a b . c)) (test (append '(a) 'b) '(a . b)) (test (append 'a) 'a) (test (assoc 'c '((a . a) (b . b))) #f) (test (assoc 'b '((a . a) (b . b))) '(b . b)) (test (assoc 'a '((a . a) (b . b))) '(a . a)) (test (assoc 'x '()) #f) (test (assoc '(x) '(((x) . x))) '((x) . x)) (test (assoc "x" '(("x" . x))) '("x" . x)) (test (assoc 1 '((1 . x))) '(1 . x)) (test (assoc #\x '((#\x . x))) '(#\x . x)) (test (assv 'c '((a . a) (b . b))) #f) (test (assv 'b '((a . a) (b . b))) '(b . b)) (test (assv 'a '((a . a) (b . b))) '(a . a)) (test (assv 'x '()) #f) (test (assv '(x) '(((x) . x))) #f) (test (assv "x" '(("x" . x))) #f) (test (assv 1 '((1 . x))) '(1 . x)) (test (assv #\x '((#\x . x))) '(#\x . x)) (test (assq 'c '((a . a) (b . b))) #f) (test (assq 'b '((a . a) (b . b))) '(b . b)) (test (assq 'a '((a . a) (b . b))) '(a . a)) (test (assq 'x '()) #f) (test (assq '(x) '(((x) . x))) #f) (test (assq "x" '(("x" . x))) #f) (define tree '((((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8))) . (((9 . 10) . (11 . 12)) . ((13 . 14) . (15 . 16))))) (test (caar tree) '((1 . 2) . (3 . 4))) (test (cadr tree) '((9 . 10) . (11 . 12))) (test (cdar tree) '((5 . 6) . (7 . 8))) (test (cddr tree) '((13 . 14) . (15 . 16))) (test (caaar tree) '(1 . 2)) (test (caadr tree) '(9 . 10)) (test (cadar tree) '(5 . 6)) (test (caddr tree) '(13 . 14)) (test (cdaar tree) '(3 . 4)) (test (cdadr tree) '(11 . 12)) (test (cddar tree) '(7 . 8)) (test (cdddr tree) '(15 . 16)) (test (caaaar tree) 1) (test (caaadr tree) 9) (test (caadar tree) 5) (test (caaddr tree) 13) (test (cadaar tree) 3) (test (cadadr tree) 11) (test (caddar tree) 7) (test (cadddr tree) 15) (test (cdaaar tree) 2) (test (cdaadr tree) 10) (test (cdadar tree) 6) (test (cdaddr tree) 14) (test (cddaar tree) 4) (test (cddadr tree) 12) (test (cdddar tree) 8) (test (cddddr tree) 16) (test (car '(1 1)) 1) (test (car '(1 . 2)) 1) (test (cdr '(1 2)) '(2)) (test (cdr '(1 . 2)) 2) (test (cons 1 2) '(1 . 2)) (test (cons 1 '(2)) '(1 2)) (test (cons 1 (cons 2 '())) '(1 2)) (test (length '()) 0) (test (length '(1)) 1) (test (length '(1 2 3)) 3) (test (list) '()) (test (list '()) '(())) (test (list 'x) '(x)) (test (list (list 'x)) '((x))) (test (list 'a 'b) '(a b)) (test (list 'a 'b 'c) '(a b c)) (test (list 'a 'b 'c 'd) '(a b c d)) (test (list 'a 'b 'c 'd 'e) '(a b c d e)) (test (list-ref '(1 2 3) 0) 1) (test (list-ref '(1 2 3) 1) 2) (test (list-ref '(1 2 3) 2) 3) (test (list-tail '(1 2 3) 0) '(1 2 3)) (test (list-tail '(1 2 3) 1) '(2 3)) (test (list-tail '(1 2 3) 2) '(3)) (test (list-tail '(1 2 3) 3) '()) (test (list? #f) #f) (test (list? #\c) #f) (test (list? 1) #f) (test (list? '(pair)) #t) (test (list? (lambda () #f)) #f) (test (list? "string") #f) (test (list? 'symbol) #f) (test (list? '#(vector)) #f) (test (list? (current-input-port)) #f) (test (list? (current-output-port)) #f) (test (list? '()) #t) (test (list? '(1)) #t) (test (list? '(1 . ())) #t) (test (list? '(1 2 3)) #t) (test (list? '(1 . 2)) #f) (test (list? '(1 2 . 3)) #f) (let ((cyclic2 (list 1 2)) (cyclic3 (list 1 2 3))) (set-cdr! (cdr cyclic2) cyclic2) (set-cdr! (cddr cyclic3) cyclic3) (if (list? cyclic2) (fail '(list? 'cyclic2) #t) (test (list? 'cyclic2) #f)) (if (list? cyclic3) (fail '(list? 'cyclic3) #t) (test (list? 'cyclic3) #f))) (test (member 'c '(a b)) #f) (test (member 'b '(a b)) '(b)) (test (member 'a '(a b)) '(a b)) (test (member 'x '()) #f) (test (member '(x) '((x))) '((x))) (test (member "x" '("x")) '("x")) (test (member 1 '(1)) '(1)) (test (member #\x '(#\x)) '(#\x)) (test (memv 'c '(a b)) #f) (test (memv 'b '(a b)) '(b)) (test (memv 'a '(a b)) '(a b)) (test (memv 'x '()) #f) (test (memv '(x) '((x))) #f) (test (memv "x" '("x")) #f) (test (memv 1 '(1)) '(1)) (test (memv #\x '(#\x)) '(#\x)) (test (memq 'c '(a b)) #f) (test (memq 'b '(a b)) '(b)) (test (memq 'a '(a b)) '(a b)) (test (memq 'x '()) #f) (test (memq '(x) '((x))) #f) (test (memq "x" '("x")) #f) (test (null? #f) #f) (test (null? #\c) #f) (test (null? 1) #f) (test (null? '(pair)) #f) (test (null? (lambda () #f)) #f) (test (null? "string") #f) (test (null? 'symbol) #f) (test (null? '#(vector)) #f) (test (null? (current-input-port)) #f) (test (null? (current-output-port)) #f) (test (null? '()) #t) (test (reverse '(1)) '(1)) (test (reverse '(1 2 3)) '(3 2 1)) (test (reverse '()) '()) (test (reverse! (list 1 2 3)) '(3 2 1)) (test (reverse! '()) '()) (test (let ((x (list 1 2 3))) (reverse! x) x) '(1)) ; --- arithmetics --- (test (+ 1234567890 9876543210) 11111111100) (test (+ 1234567890 -9876543210) -8641975320) (test (+ -1234567890 9876543210) 8641975320) (test (+ -1234567890 -9876543210) -11111111100) (test (+ 9876543210 1234567890) 11111111100) (test (+ 9876543210 -1234567890) 8641975320) (test (+ -9876543210 1234567890) -8641975320) (test (+ -9876543210 -1234567890) -11111111100) (test (+ 1234567890 0) 1234567890) (test (+ 0 1234567890) 1234567890) (test (+ 1 2 3 4 5 6 7 8 9 10) 55) (test (+ 1) 1) (test (+) 0) (test (- 1234567890 9876543210) -8641975320) (test (- 1234567890 -9876543210) 11111111100) (test (- -1234567890 9876543210) -11111111100) (test (- -1234567890 -9876543210) 8641975320) (test (- 9876543210 1234567890) 8641975320) (test (- 9876543210 -1234567890) 11111111100) (test (- -9876543210 1234567890) -11111111100) (test (- -9876543210 -1234567890) -8641975320) (test (- 1234567890 0) 1234567890) (test (- 0 1234567890) -1234567890) (test (- 1 2 3 4 5 6 7 8 9 10) -53) (test (- 1234567890) -1234567890) (test (- 0) 0) (test (* 1234567 7654321) 9449772114007) (test (* 1234567 -7654321) -9449772114007) (test (* -1234567 7654321) -9449772114007) (test (* -1234567 -7654321) 9449772114007) (test (* 7654321 1234567) 9449772114007) (test (* 7654321 -1234567) -9449772114007) (test (* -7654321 1234567) -9449772114007) (test (* -7654321 -1234567) 9449772114007) (test (* 1234567 1) 1234567) (test (* 1 1234567) 1234567) (test (* 1234567 0) 0) (test (* 0 1234567) 0) (test (* 1 2 3 4 5 6 7 8 9 10) 3628800) (test (* 1 2 3 4 5 6 7 8 9) 362880) (test (* 2) 2) (test (*) 1) (test (< 1234567890 9876543210) #t) (test (< 1234567890 -9876543210) #f) (test (< -1234567890 9876543210) #t) (test (< -1234567890 -9876543210) #f) (test (< 9876543210 1234567890) #f) (test (< 9876543210 -1234567890) #f) (test (< -9876543210 1234567890) #t) (test (< -9876543210 -1234567890) #t) (test (< -1234567890 -1234567890) #f) (test (< 1234567890 1234567890) #f) (test (< 1234567890 0) #f) (test (< 0 1234567890) #t) (test (< 1 2 3 4 5 6 7 8 9 10) #t) (test (< 1 2 3 4 5 6 7 8 9 9) #f) (test (<= 1234567890 9876543210) #t) (test (<= 1234567890 -9876543210) #f) (test (<= -1234567890 9876543210) #t) (test (<= -1234567890 -9876543210) #f) (test (<= 9876543210 1234567890) #f) (test (<= 9876543210 -1234567890) #f) (test (<= -9876543210 1234567890) #t) (test (<= -9876543210 -1234567890) #t) (test (<= -1234567890 -1234567890) #t) (test (<= 1234567890 1234567890) #t) (test (<= 1234567890 0) #f) (test (<= 0 1234567890) #t) (test (<= 1 2 3 4 5 6 7 8 9 10) #t) (test (<= 1 2 3 4 5 6 7 8 9 9) #t) (test (= 1234567890 9876543210) #f) (test (= 1234567890 -9876543210) #f) (test (= -1234567890 9876543210) #f) (test (= -1234567890 -9876543210) #f) (test (= 9876543210 1234567890) #f) (test (= 9876543210 -1234567890) #f) (test (= -9876543210 1234567890) #f) (test (= -9876543210 -1234567890) #f) (test (= -1234567890 1234567890) #f) (test (= 1234567890 -1234567890) #f) (test (= 1234567890 1234567890) #t) (test (= -1234567890 -1234567890) #t) (test (= 0 0) #t) (test (= 0 1234567890) #f) (test (= 1234567890 0) #f) (test (= 1 1 1 1 1 1 1 1 1 1) #t) (test (= 1 1 1 1 1 1 1 1 1 0) #f) (test (> 1234567890 9876543210) #f) (test (> 1234567890 -9876543210) #t) (test (> -1234567890 9876543210) #f) (test (> -1234567890 -9876543210) #t) (test (> 9876543210 1234567890) #t) (test (> 9876543210 -1234567890) #t) (test (> -9876543210 1234567890) #f) (test (> -9876543210 -1234567890) #f) (test (> -1234567890 -1234567890) #f) (test (> 1234567890 1234567890) #f) (test (> 1234567890 0) #t) (test (> 0 1234567890) #f) (test (> 9 8 7 6 5 4 3 2 1 0) #t) (test (> 9 8 7 6 5 4 3 2 1 1) #f) (test (>= 1234567890 9876543210) #f) (test (>= 1234567890 -9876543210) #t) (test (>= -1234567890 9876543210) #f) (test (>= -1234567890 -9876543210) #t) (test (>= 9876543210 1234567890) #t) (test (>= 9876543210 -1234567890) #t) (test (>= -9876543210 1234567890) #f) (test (>= -9876543210 -1234567890) #f) (test (>= -1234567890 -1234567890) #t) (test (>= 1234567890 1234567890) #t) (test (>= 1234567890 0) #t) (test (>= 0 1234567890) #f) (test (>= 9 8 7 6 5 4 3 2 1 0) #t) (test (>= 9 8 7 6 5 4 3 2 1 1) #t) (test (abs 1234567890) 1234567890) (test (abs -1234567890) 1234567890) (test (abs 0) 0) (test (even? -1) #f) (test (even? 0) #t) (test (even? 1) #f) (test (even? 2) #t) (test (even? 1234567890) #t) (test (even? 1234567891) #f) (test (expt 0 2) 0) (test (expt 2 0) 1) (test (expt 2 1) 2) (test (expt 2 2) 4) (test (expt 2 3) 8) (test (expt -2 3) -8) (test (expt -2 4) 16) (test (expt 2 100) 1267650600228229401496703205376) (test (gcd) 0) (test (gcd 17) 17) (test (gcd 18 12) 6) (test (gcd 289 85 34) 17) (test (lcm) 1) (test (lcm 17) 17) (test (lcm 12 18) 36) (test (lcm 5 12 18) 180) (test (min 1) 1) (test (min 2 1 3) 1) (test (min 2 1 -2 -1 3) -2) (test (max 1) 1) (test (max 2 3 1) 3) (test (max 2 -2 5 -1 3) 5) (test (modulo 1234567890 12345) 6165) (test (modulo 1234567890 -12345) -6180) (test (modulo -1234567890 12345) 6180) (test (modulo -1234567890 -12345) -6165) (test (modulo 12345 1234567890) 12345) (test (modulo 12345 -1234567890) -1234555545) (test (modulo -12345 1234567890) 1234555545) (test (modulo -12345 -1234567890) -12345) (test (modulo 12345 12345) 0) (test (modulo 12345 -12345) 0) (test (modulo -12345 12345) 0) (test (modulo -12345 -12345) 0) (test (negative? -1) #t) (test (negative? 0) #f) (test (negative? 1) #f) (test (not #f) #t) (test (not #\c) #f) (test (not 1) #f) (test (not '(pair)) #f) (test (not (lambda () #f)) #f) (test (not "string") #f) (test (not 'symbol) #f) (test (not '#(vector)) #f) (test (not (current-input-port)) #f) (test (not (current-output-port)) #f) (test (odd? -1) #t) (test (odd? 0) #f) (test (odd? 1) #t) (test (odd? 2) #f) (test (odd? 1234567890) #f) (test (odd? 1234567891) #t) (test (positive? -1) #f) (test (positive? 0) #f) (test (positive? 1) #t) (test (quotient 1234567890 12345) 100005) (test (quotient 1234567890 -12345) -100005) (test (quotient -1234567890 12345) -100005) (test (quotient -1234567890 -12345) 100005) (test (quotient 12345 1234567890) 0) (test (quotient 12345 -1234567890) 0) (test (quotient -12345 1234567890) 0) (test (quotient -12345 -1234567890) 0) (test (quotient 12345 12345) 1) (test (quotient 12345 -12345) -1) (test (quotient -12345 12345) -1) (test (quotient -12345 -12345) 1) (test (remainder 1234567890 12345) 6165) (test (remainder 1234567890 -12345) 6165) (test (remainder -1234567890 12345) -6165) (test (remainder -1234567890 -12345) -6165) (test (remainder 12345 1234567890) 12345) (test (remainder 12345 -1234567890) 12345) (test (remainder -12345 1234567890) -12345) (test (remainder -12345 -1234567890) -12345) (test (remainder 12345 12345) 0) (test (remainder 12345 -12345) 0) (test (remainder -12345 12345) 0) (test (remainder -12345 -12345) 0) (test (zero? -1) #f) (test (zero? 0) #t) (test (zero? 1) #f) ; --- s9fes bit ops --- (define (mask x) (bit-op 1 #b1111 x)) (test (mask (bit-op 0 #b0011 #b0101)) 0) (test (mask (bit-op 1 #b0011 #b0101)) 1) (test (mask (bit-op 2 #b0011 #b0101)) 2) (test (mask (bit-op 3 #b0011 #b0101)) 3) (test (mask (bit-op 4 #b0011 #b0101)) 4) (test (mask (bit-op 5 #b0011 #b0101)) 5) (test (mask (bit-op 6 #b0011 #b0101)) 6) (test (mask (bit-op 7 #b0011 #b0101)) 7) (test (mask (bit-op 8 #b0011 #b0101)) 8) (test (mask (bit-op 9 #b0011 #b0101)) 9) (test (mask (bit-op 10 #b0011 #b0101)) 10) (test (mask (bit-op 11 #b0011 #b0101)) 11) (test (mask (bit-op 12 #b0011 #b0101)) 12) (test (mask (bit-op 13 #b0011 #b0101)) 13) (test (mask (bit-op 14 #b0011 #b0101)) 14) (test (mask (bit-op 15 #b0011 #b0101)) 15) ; --- equivalence --- (test (eq? 'x 'x) #t) (test (eq? eq? eq?) #t) (test (eq? '() '()) #t) (test (eq? 'x 'y) #f) (test (eq? 'x '(x . y)) #f) (test ((lambda (x) (eq? x x)) '(x . y)) #t) (test (eq? #t #t) #t) (test (eq? #f #f) #t) (test (eq? (list 'pair) (list 'pair)) #f) (test (eq? (lambda () #f) (lambda () #f)) #f) (test (eq? "string" "string") #f) (test (eq? 'symbol 'symbol) #t) (test (eq? (vector 'vector) (vector 'vector)) #f) (test (eqv? #f #f) #t) (test (eqv? #\c #\c) #t) (test (eqv? 1 1) #t) (test (eqv? (list 'pair) (list 'pair)) #f) (test (eqv? (lambda () #f) (lambda () #f)) #f) (test (eqv? "string" "string") #f) (test (eqv? 'symbol 'symbol) #t) (test (eqv? (vector 'vector) (vector 'vector)) #f) (test (equal? #f #f) #t) (test (equal? #\c #\c) #t) (test (equal? 1 1) #t) (test (equal? '(pair) '(pair)) #t) (test (equal? '(pair (1)) '(pair (2))) #f) (test (equal? (lambda () #f) (lambda () #f)) #f) (test (equal? "string" "string") #t) (test (equal? 'symbol 'symbol) #t) (test (equal? '#(vector) #(vector)) #t) (test (equal? '#(vector (list) vector) #(vector (list) vector)) #t) (test (equal? '#(vector #(vector) vector) #(vector #(vector) vector)) #t) (test (equal? '#(vector #(vec1) vector) #(vector #(vec2) vector)) #f) (test (equal? tree tree) #t) (test (equal? #f #\c) #f) (test (equal? #f 1) #f) (test (equal? #f '(pair)) #f) (test (equal? #f (lambda () #f)) #f) (test (equal? #f "string") #f) (test (equal? #f 'symbol) #f) (test (equal? #f '#(vector)) #f) (test (equal? #f (current-input-port)) #f) (test (equal? #f (current-output-port)) #f) (test (equal? #\c 1) #f) (test (equal? #\c '(pair)) #f) (test (equal? #\c (lambda () #f)) #f) (test (equal? #\c "string") #f) (test (equal? #\c 'symbol) #f) (test (equal? #\c '#(vector)) #f) (test (equal? #\c (current-input-port)) #f) (test (equal? #\c (current-output-port)) #f) (test (equal? 1 '(pair)) #f) (test (equal? 1 (lambda () #f)) #f) (test (equal? 1 "string") #f) (test (equal? 1 'symbol) #f) (test (equal? 1 '#(vector)) #f) (test (equal? 1 (current-input-port)) #f) (test (equal? 1 (current-output-port)) #f) (test (equal? '(pair) (lambda () #f)) #f) (test (equal? '(pair) "string") #f) (test (equal? '(pair) 'symbol) #f) (test (equal? '(pair) '#(vector)) #f) (test (equal? '(pair) (current-input-port)) #f) (test (equal? '(pair) (current-output-port)) #f) (test (equal? (lambda () #f) "string") #f) (test (equal? (lambda () #f) 'symbol) #f) (test (equal? (lambda () #f) '#(vector)) #f) (test (equal? (lambda () #f) (current-input-port)) #f) (test (equal? (lambda () #f) (current-output-port)) #f) (test (equal? "string" 'symbol) #f) (test (equal? "string" '#(vector)) #f) (test (equal? "string" (current-input-port)) #f) (test (equal? "string" (current-output-port)) #f) (test (equal? 'symbol '#(vector)) #f) (test (equal? 'symbol (current-input-port)) #f) (test (equal? 'symbol (current-output-port)) #f) (test (equal? '#(vector) (current-input-port)) #f) (test (equal? '#(vector) (current-output-port)) #f) (test (equal? (current-input-port) (current-output-port)) #f) (test (let ((x (list 1))) (equal? x x)) #t) (test (equal? '(a (b c) (d (e . f) g)) '(a (b c) (d (e . f) g))) #t) (test (equal? '(a (b c) (d (e . x) g)) '(a (b c) (d (e . f) g))) #f) (test (equal? '#(a (b c) (d (e . f) g)) '#(a (b c) (d (e . f) g))) #t) (test (equal? '#(a (b c) (d (e . x) g)) '#(a (b c) (d (e . f) g))) #f) ; --- chars --- (test (char-alphabetic? #\a) #t) (test (char-alphabetic? #\A) #t) (test (char-alphabetic? #\z) #t) (test (char-alphabetic? #\Z) #t) (test (char-alphabetic? #\@) #f) (test (char-alphabetic? #\[) #f) (test (char-alphabetic? #\`) #f) (test (char-alphabetic? #\{) #f) (test (char-ci? #\+ #\+) #f) (test (char-ci>? #\+ #\-) #f) (test (char-ci>? #\A #\A) #f) (test (char-ci>? #\A #\a) #f) (test (char-ci>? #\a #\A) #f) (test (char-ci>? #\a #\a) #f) (test (char-ci>? #\A #\Z) #f) (test (char-ci>? #\A #\z) #f) (test (char-ci>? #\a #\Z) #f) (test (char-ci>? #\a #\z) #f) (test (char-ci>? #\Z #\A) #t) (test (char-ci>? #\Z #\a) #t) (test (char-ci>? #\z #\A) #t) (test (char-ci>? #\z #\a) #t) (test (char-ci>? #\a #\b #\c) #f) (test (char-ci>? #\a #\b #\b) #f) (test (char-ci>? #\b #\b #\a) #f) (test (char-ci>? #\c #\b #\a) #t) (test (char-ci>=? #\+ #\+) #t) (test (char-ci>=? #\+ #\-) #f) (test (char-ci>=? #\A #\A) #t) (test (char-ci>=? #\A #\a) #t) (test (char-ci>=? #\a #\A) #t) (test (char-ci>=? #\a #\a) #t) (test (char-ci>=? #\A #\Z) #f) (test (char-ci>=? #\A #\z) #f) (test (char-ci>=? #\a #\Z) #f) (test (char-ci>=? #\a #\z) #f) (test (char-ci>=? #\Z #\A) #t) (test (char-ci>=? #\Z #\a) #t) (test (char-ci>=? #\z #\A) #t) (test (char-ci>=? #\z #\a) #t) (test (char-ci>=? #\a #\b #\c) #f) (test (char-ci>=? #\a #\b #\b) #f) (test (char-ci>=? #\b #\b #\a) #t) (test (char-ci>=? #\c #\b #\a) #t) (test (char-downcase #\a) #\a) (test (char-downcase #\A) #\a) (test (char-downcase #\z) #\z) (test (char-downcase #\Z) #\z) (test (char-downcase #\@) #\@) (test (char-downcase #\[) #\[) (test (char-downcase #\`) #\`) (test (char-downcase #\{) #\{) (test (char-lower-case? #\a) #t) (test (char-lower-case? #\A) #f) (test (char-lower-case? #\z) #t) (test (char-lower-case? #\Z) #f) (test (char-lower-case? #\@) #f) (test (char-lower-case? #\[) #f) (test (char-lower-case? #\`) #f) (test (char-lower-case? #\{) #f) (test (char-numeric? #\0) #t) (test (char-numeric? #\9) #t) (test (char-numeric? #\/) #f) (test (char-numeric? #\:) #f) (test (char-upcase #\a) #\A) (test (char-upcase #\A) #\A) (test (char-upcase #\z) #\Z) (test (char-upcase #\Z) #\Z) (test (char-upcase #\@) #\@) (test (char-upcase #\[) #\[) (test (char-upcase #\`) #\`) (test (char-upcase #\{) #\{) (test (char-upper-case? #\a) #f) (test (char-upper-case? #\A) #t) (test (char-upper-case? #\z) #f) (test (char-upper-case? #\Z) #t) (test (char-upper-case? #\@) #f) (test (char-upper-case? #\[) #f) (test (char-upper-case? #\`) #f) (test (char-upper-case? #\{) #f) (test (char-whitespace? #\0) #f) (test (char-whitespace? #\9) #f) (test (char-whitespace? #\a) #f) (test (char-whitespace? #\z) #f) (test (char-whitespace? #\ ) #t) (test (char-whitespace? #\space) #t) (test (char-whitespace? #\newline) #t) (test (char-whitespace? (integer->char 9)) #t) (test (char-whitespace? (integer->char 10)) #t) (test (char-whitespace? (integer->char 12)) #t) (test (char-whitespace? (integer->char 13)) #t) (test (char? #\+ #\+) #f) (test (char>? #\+ #\-) #f) (test (char>? #\A #\A) #f) (test (char>? #\A #\a) #f) (test (char>? #\a #\A) #t) (test (char>? #\a #\a) #f) (test (char>? #\A #\Z) #f) (test (char>? #\A #\z) #f) (test (char>? #\a #\Z) #t) (test (char>? #\a #\z) #f) (test (char>? #\Z #\A) #t) (test (char>? #\Z #\a) #f) (test (char>? #\z #\A) #t) (test (char>? #\z #\a) #t) (test (char>? #\a #\b #\c) #f) (test (char>? #\a #\a #\b) #f) (test (char>? #\c #\c #\b) #f) (test (char>? #\c #\b #\a) #t) (test (char>=? #\+ #\+) #t) (test (char>=? #\+ #\-) #f) (test (char>=? #\A #\A) #t) (test (char>=? #\A #\a) #f) (test (char>=? #\a #\A) #t) (test (char>=? #\a #\a) #t) (test (char>=? #\A #\Z) #f) (test (char>=? #\A #\z) #f) (test (char>=? #\a #\Z) #t) (test (char>=? #\a #\z) #f) (test (char>=? #\Z #\A) #t) (test (char>=? #\Z #\a) #f) (test (char>=? #\z #\A) #t) (test (char>=? #\z #\a) #t) (test (char>=? #\a #\b #\c) #f) (test (char>=? #\a #\a #\b) #f) (test (char>=? #\c #\c #\b) #t) (test (char>=? #\c #\b #\a) #t) ; --- strings --- (define (string-downcase s) (list->string (map char-downcase (string->list s)))) (test (make-string 0) "") (test (make-string 1) " ") (test (make-string 3 #\x) "xxx") (test (number->string 0) "0") (test (number->string 123) "123") (test (number->string 165 2) "10100101") (test (number->string 375 8) "567") (test (number->string 789 10) "789") (test (string-downcase (number->string 11259375 16)) "abcdef") (test (number->string +165 2) "10100101") (test (number->string +375 8) "567") (test (number->string +789 10) "789") (test (string-downcase (number->string +11259375 16)) "abcdef") (test (number->string -165 2) "-10100101") (test (number->string -375 8) "-567") (test (number->string -789 10) "-789") (test (string-downcase (number->string -11259375 16)) "-abcdef") (test (string) "") (test (string #\x) "x") (test (string #\a #\b #\c) "abc") (test (string->number "") #f) (test (string->number "+") #f) (test (string->number "-") #f) (test (string->number "0") 0) (test (string->number "123") 123) (test (string->number "10100101" 2) 165) (test (string->number "567" 8) 375) (test (string->number "789" 10) 789) (test (string->number "abcdef" 16) 11259375) (test (string->number "+1010" 2) 10) (test (string->number "+123" 8) 83) (test (string->number "+123" 10) 123) (test (string->number "+123" 16) 291) (test (string->number "-1010" 2) -10) (test (string->number "-123" 8) -83) (test (string->number "-123" 10) -123) (test (string->number "-123" 16) -291) (test (string->number "02" 2) #f) (test (string->number "08" 8) #f) (test (string->number "0a" 10) #f) (test (string->number "0g" 16) #f) (test (string->number " 1") #f) (test (string->number "1 ") #f) (test (string->number "+1 ") #f) (test (string->number "-1 ") #f) (test (string-append "" "") "") (test (string-append "abc" "") "abc") (test (string-append "" "def") "def") (test (string-append) "") (test (string-append "abc") "abc") (test (string-append "abc" "def") "abcdef") (test (string-append "abc" "def" "xyz") "abcdefxyz") (test (string-ci? "test" "test") #f) (test (string-ci>? "test" "tesa") #t) (test (string-ci>? "test" "tesz") #f) (test (string-ci>? "TEST" "tesa") #t) (test (string-ci>? "TEST" "tesz") #f) (test (string-ci>? "test" "TESA") #t) (test (string-ci>? "test" "TESZ") #f) (test (string-ci>? "TEST" "TESA") #t) (test (string-ci>? "TEST" "TESZ") #f) (test (string-ci>? "test" "tes") #t) (test (string-ci>? "test" "test0") #f) (test (string-ci>? "test0" "test") #t) (test (string-ci>? "ab" "cd" "ef") #f) (test (string-ci>? "ab" "ab" "cd") #f) (test (string-ci>? "cd" "cd" "ab") #f) (test (string-ci>? "ef" "cd" "ab") #t) (test (string-ci>=? "test" "test") #t) (test (string-ci>=? "test" "tesa") #t) (test (string-ci>=? "test" "tesz") #f) (test (string-ci>=? "TEST" "tesa") #t) (test (string-ci>=? "TEST" "tesz") #f) (test (string-ci>=? "test" "TESA") #t) (test (string-ci>=? "test" "TESZ") #f) (test (string-ci>=? "TEST" "TESA") #t) (test (string-ci>=? "TEST" "TESZ") #f) (test (string-ci>=? "test" "tes") #t) (test (string-ci>=? "test" "test0") #f) (test (string-ci>=? "test0" "test") #t) (test (string-ci>=? "ab" "cd" "ef") #f) (test (string-ci>=? "ab" "ab" "cd") #f) (test (string-ci>=? "cd" "cd" "ab") #t) (test (string-ci>=? "ef" "cd" "ab") #t) (test (string-copy "") "") (test (string-copy "abcdef") "abcdef") (test (begin (let ((s "abc")) (let ((s2 (string-copy s))) (string-set! s2 1 #\x) s))) "abc") (test (let ((s (make-string 1))) (string-fill! s #\x) s) "x") (test (let ((s (make-string 3))) (string-fill! s #\z) s) "zzz") (test (string-length "") 0) (test (string-length "a") 1) (test (string-length "ab") 2) (test (string-length "abc") 3) (test (string-length "Hello, World!") 13) (test (string-ref "abc" 0) #\a) (test (string-ref "abc" 1) #\b) (test (string-ref "abc" 2) #\c) (define s (string #\1 #\2 #\3)) (test (begin (string-set! s 0 #\a) s) "a23") (test (begin (string-set! s 2 #\c) s) "a2c") (test (begin (string-set! s 1 #\b) s) "abc") (test (string? "test" "test") #f) (test (string>? "test" "tesa") #t) (test (string>? "test" "tesz") #f) (test (string>? "TEST" "tesa") #f) (test (string>? "TEST" "tesz") #f) (test (string>? "test" "TESA") #t) (test (string>? "test" "TESZ") #t) (test (string>? "TEST" "TESA") #t) (test (string>? "TEST" "TESZ") #f) (test (string>? "test" "tes") #t) (test (string>? "test" "test0") #f) (test (string>? "test0" "test") #t) (test (string>? "ab" "cd" "ef") #f) (test (string>? "ab" "ab" "cd") #f) (test (string>? "cd" "cd" "ab") #f) (test (string>? "ef" "cd" "ab") #t) (test (string>=? "test" "test") #t) (test (string>=? "test" "tesa") #t) (test (string>=? "test" "tesz") #f) (test (string>=? "TEST" "tesa") #f) (test (string>=? "TEST" "tesz") #f) (test (string>=? "test" "TESA") #t) (test (string>=? "test" "TESZ") #t) (test (string>=? "TEST" "TESA") #t) (test (string>=? "TEST" "TESZ") #f) (test (string>=? "test" "tes") #t) (test (string>=? "test" "test0") #f) (test (string>=? "test0" "test") #t) (test (string>=? "ab" "cd" "ef") #f) (test (string>=? "ab" "ab" "cd") #f) (test (string>=? "cd" "cd" "ab") #t) (test (string>=? "ef" "cd" "ab") #t) (test (substring "" 0 0) "") (test (substring "abc" 0 0) "") (test (substring "abc" 0 1) "a") (test (substring "abc" 0 2) "ab") (test (substring "abc" 0 3) "abc") (test (substring "abc" 1 1) "") (test (substring "abc" 1 2) "b") (test (substring "abc" 1 3) "bc") (test (substring "abc" 2 2) "") (test (substring "abc" 2 3) "c") (test (substring "abc" 3 3) "") ; --- vectors --- (test (make-vector 0) #()) (test (make-vector 1) #(#f)) (test (make-vector 3 'x) #(x x x)) (test (vector) '#()) (test (vector 'x) '#(x)) (test (vector 1 2 3) '#(1 2 3)) (test (vector (vector 'x)) '#(#(x))) (test (let ((v (vector))) (vector-fill! v 'x) v) '#()) (test (let ((v (vector 1 2 3))) (vector-fill! v 'z) v) '#(z z z)) (test (vector-length #()) 0) (test (vector-length #(a)) 1) (test (vector-length #(a b)) 2) (test (vector-length #(a b c)) 3) (test (vector-length #(1 2 3 #(4 5 6) 7 8 9)) 7) (test (vector-ref #(a b c) 0) 'a) (test (vector-ref #(a b c) 1) 'b) (test (vector-ref #(a b c) 2) 'c) (define v (vector 1 2 3)) (test (begin (vector-set! v 0 'a) v) '#(a 2 3)) (test (begin (vector-set! v 2 'c) v) '#(a 2 c)) (test (begin (vector-set! v 1 'b) v) '#(a b c)) ; --- I/O --- (if (file-exists? testfile) (delete-file testfile)) (test (call-with-output-file testfile (lambda (out) (write '(this is a test) out) (close-output-port out) (call-with-input-file testfile read))) '(this is a test)) (delete-file testfile) (test (let ((out (open-output-file testfile))) (write '(this is a test) out) (close-output-port out) (let ((in (open-input-file testfile))) (let ((x (read in))) (close-input-port in) x))) '(this is a test)) (delete-file testfile) (test (let ((out (open-output-file testfile))) (display "Hello-World" out) (close-output-port out) (let ((in (open-input-file testfile))) (let ((x (read in))) (close-input-port in) x))) 'hello-world) (delete-file testfile) (test (begin (with-output-to-file testfile (lambda () (write '(this is a test)))) (with-input-from-file testfile read)) '(this is a test)) (define (visibility-check x) (delete-file testfile) (let ((out (open-output-file testfile))) (write x out) (display #\space out) (display x out) (display #\space out) (write 'the-end out) (close-output-port out) (let ((in (open-input-file testfile))) (let ((vis (read in))) (let ((invis (read in))) (close-input-port in) (list vis invis)))))) (test (visibility-check #f) '(#f #f)) (test (visibility-check 1) '(1 1)) (test (visibility-check 12345678901234567890) '(12345678901234567890 12345678901234567890)) (test (visibility-check -12345678901234567890) '(-12345678901234567890 -12345678901234567890)) (test (visibility-check #\A) '(#\A a)) (test (visibility-check "x y") '("x y" x)) (test (visibility-check 'foo) '(foo foo)) (test (visibility-check '(1 2 3)) '((1 2 3) (1 2 3))) (test (visibility-check '#(1 2 3)) '(#(1 2 3) #(1 2 3))) (test (visibility-check " ") '(" " the-end)) (test (visibility-check #\space) '(#\space the-end)) (test (visibility-check #\newline) '(#\newline the-end)) (delete-file testfile) (test (begin (with-output-to-file testfile newline) (with-input-from-file testfile read-char)) #\newline) (delete-file testfile) (test (begin (call-with-output-file testfile (lambda (out) (newline out) (close-output-port out))) (call-with-input-file testfile read-char)) #\newline) (delete-file testfile) (test (begin (close-output-port (open-output-file testfile)) (let* ((in (open-input-file testfile)) (e (read in))) (close-input-port in) (eof-object? e))) #t) (delete-file testfile) (define foo 'bar) (test (let ((out (open-output-file testfile))) (write '(define foo 'baz) out) (close-output-port out) (load testfile) foo) 'baz) (define (with-range lo hi fn) (if (< hi lo) '() (cons (fn lo) (with-range (+ 1 lo) hi fn)))) (delete-file testfile) (test (call-with-output-file testfile (lambda (out) (with-range 32 126 (lambda (x) (write-char (integer->char x) out) (integer->char x))))) (with-range 32 126 integer->char)) (define (while-not-eof input fn) (let ((c (fn input))) (if (eof-object? c) '() (cons c (while-not-eof input fn))))) (test (let ((in (open-input-file testfile))) (while-not-eof in read-char)) (with-range 32 126 integer->char)) (test (let ((in (open-input-file testfile))) (let ((c (peek-char in))) (cons c (while-not-eof in read-char)))) (cons #\space (with-range 32 126 integer->char))) ; does GC close unused files? ; Set NFILES to a number that is greater than MAX_PORTS in s9.h (let ((NFILES 100)) (test (letrec ((open (lambda (n) (open-input-file testfile) (if (< n 1) 'okay (open (- n 1)))))) (open NFILES)) 'okay)) ; === Beginning of R4RS tests === ; R4RS tests, 6.1 booleans (test #t #t) (test #f #f) (test '#f #f) (test (not #t) #f) (test (not 3) #f) (test (not (list 3)) #f) (test (not #f) #t) (test (not '()) #f) (test (not (list)) #f) (test (not 'nil) #f) (test (boolean? #f) #t) (test (boolean? 0) #f) (test (boolean? '()) #f) ; R4RS tests, 6.2 equivalence predicates (test (eqv? 'a 'a) #t) (test (eqv? 'a 'b) #f) (test (eqv? 2 2) #t) (test (eqv? '() '()) #t) (test (eqv? 100000000 100000000) #t) (test (eqv? (cons 1 2) (cons 1 2)) #f) (test (eqv? (lambda () 1) (lambda () 2)) #f) (test (eqv? #f 'nil) #f) (test (let ((p (lambda (x) x))) (eqv? p p)) #t) (define gen-counter (lambda () (let ((n 0)) (lambda () (set! n (+ n 1)) n)))) (test (let ((g (gen-counter))) (eqv? g g)) #t) (test (eqv? (gen-counter) (gen-counter)) #f) (define gen-loser (lambda () (let ((n 0)) (lambda () (set! n (+ n 1)) 27)))) (test (let ((g (gen-loser))) (eqv? g g)) #t) (test (letrec ((f (lambda () (if (eqv? f g) 'f 'both))) (g (lambda () (if (eqv? f g) 'g 'both)))) (eqv? (f) (g))) #t) (test (let ((x '(a))) (eqv? x x)) #t) (test (eq? 'a 'a) #t) (test (eq? (list 'a) (list 'a)) #f) (test (eq? '() '()) #t) (test (eq? car car) #t) (test (let ((x '(a))) (eq? x x)) #t) (test (let ((x '#())) (eq? x x)) #t) (test (let ((p (lambda (x) x))) (eq? p p)) #t) (test (equal? 'a 'a) #t) (test (equal? '(a) '(a)) #t) (test (equal? '(a (b) c) '(a (b) c)) #t) (test (equal? "abc" "abc") #t) (test (equal? 2 2) #t) (test (equal? (make-vector 5 'a) (make-vector 5 'a)) #t) ; R4RS tests, 6.3 pairs and lists (test '(a . (b . (c . (d . (e . ()))))) '(a b c d e)) (test '(a . (b . (c . d))) '(a b c . d)) (define x (list 'a 'b 'c)) (define y x) (test y '(a b c)) (test (list? y) #t) (set-cdr! x 4) (test x '(a . 4)) (test (eqv? x y) #t) (test y '(a . 4)) (test (list? y) #f) (set-cdr! x x) (test (list? x) #f) (test (pair? '(a . b)) #t) (test (pair? '(a b c)) #t) (test (pair? '()) #f) (test (pair? '#(a b)) #f) (test (cons 'a '()) '(a)) (test (cons '(a) '(b c d)) '((a) b c d)) (test (cons "a" '(b c)) '("a" b c)) (test (cons 'a 3) '(a . 3)) (test (cons '(a b) 'c) '((a b) . c)) (test (car '(a b c)) 'a) (test (car '((a) b c d)) '(a)) (test (car '(1 . 2)) 1) (test (cdr '((a) b c d)) '(b c d)) (test (cdr '(1 . 2)) 2) (define x (list 'not-a-constant-list)) (set-car! x 3) (test x '(3)) (test (list? '(a b c)) #t) (test (list? '()) #t) (test (list? '(a . b)) #f) (test (let ((x (list 'a))) (set-cdr! x x) (list? x)) #f) (test (list 'a (+ 3 4) 'c) '(a 7 c)) (test (list) '()) (test (length '(a b c)) 3) (test (length '(a (b) (c d e))) 3) (test (length '()) 0) (test (append '(x) '(y)) '(x y)) (test (append '(a) '(b c d)) '(a b c d)) (test (append '(a (b)) '((c))) '(a (b) (c))) (test (append '(a b) '(c . d)) '(a b c . d)) (test (append '() 'a) 'a) (test (reverse '(a b c)) '(c b a)) (test (reverse '(a (b c) d (e (f)))) '((e (f)) d (b c) a)) (test (list-ref '(a b c d) 2) 'c) (test (memq 'a '(a b c)) '(a b c)) (test (memq 'b '(a b c)) '(b c)) (test (memq 'a '(b c d)) #f) (test (memq (list 'a) '(b (a) c)) #f) (test (member (list 'a) '(b (a) c)) '((a) c)) (test (memv 101 '(100 101 102)) '(101 102)) (define e '((a 1) (b 2) (c 3))) (test (assq 'a e) '(a 1)) (test (assq 'b e) '(b 2)) (test (assq 'd e) #f) (test (assq (list 'a) '(((a)) ((b)) ((c)))) #f) (test (assoc (list 'a) '(((a)) ((b)) ((c)))) '((a))) (test (assv 5 '((2 3) (5 7) (11 13))) '(5 7)) ; R4RS tests, 6.4 symbols (test (symbol? 'foo) #t) (test (symbol? (car '(a b))) #t) (test (symbol? "bar") #f) (test (symbol? 'nil) #t) (test (symbol? '()) #f) (test (symbol? #f) #f) (test (symbol->string 'flying-fish) "flying-fish") (test (symbol->string 'Martin) "martin") (test (symbol->string (string->symbol "Malvina")) "Malvina") (test (eq? 'mISSISSIppi 'mississippi) #t) (test (eq? 'bitBlt (string->symbol "bitBlt")) #f) (test (eq? 'JollyWog (string->symbol (symbol->string 'JollyWog))) #t) (test (string=? "K. Harper, M.D." (symbol->string (string->symbol "K. Harper, M.D."))) #t) ; R4RS tests, 6.5 numbers (test (max 3 4) 4) (test (+ 3 4) 7) (test (+ 3) 3) (test (+) 0) (test (* 4) 4) (test (*) 1) (test (- 3 4) -1) (test (- 3 4 5) -6) (test (- 3) -3) (test (abs -7) 7) (test (modulo 13 4) 1) (test (remainder 13 4) 1) (test (modulo -13 4) 3) (test (remainder -13 4) -1) (test (modulo 13 -4) -3) (test (remainder 13 -4) 1) (test (modulo -13 -4) -1) (test (remainder -13 -4) -1) (test (gcd 32 -36) 4) (test (gcd) 0) (test (lcm 32 -36) 288) (test (lcm) 1) (test (string->number "100") 100) (test (string->number "100" 16) 256) ; R4RS tests, 6.6 characters (test #\a #\a) (test #\A #\A) (test #\( #\() (test #\ #\space) (test #\space #\space) (test #\newline #\newline) ; R4RS tests, 6.7 strings (test "The word \"recursion\" has many meanings." "The word \"recursion\" has many meanings.") (define s (make-string 3 #\*)) (string-set! s 0 #\?) (test s "?**") ; R4RS tests, 6.8 vectors (test '#(0 (2 2 2 2) "Anna") #(0 (2 2 2 2) "Anna")) (test (vector 'a 'b 'c) #(a b c)) (test (vector-ref '#(1 1 2 3 5 8 13 21) 5) 8) (test (let ((vec (vector 0 '(2 2 2 2) "Anna"))) (vector-set! vec 1 '("Sue" "Sue")) vec) #(0 ("Sue" "Sue") "Anna")) (test (vector->list '#(dah dah didah)) '(dah dah didah)) (test (list->vector '(dididit dah)) '#(dididit dah)) ; R4RS tests, 6.9 control features (test (procedure? car) #t) (test (procedure? 'car) #f) (test (procedure? (lambda (x) (* x x))) #t) (test (procedure? '(lambda (x) (* x x))) #f) (test (apply + (list 3 4)) 7) (define compose (lambda (f g) (lambda args (f (apply g args))))) (define (isqrt square) (letrec ((sqrt2 (lambda (x last) (cond ((= last x) x) ((= last (+ 1 x)) (if (> (* x x) square) (- x 1) x)) (else (sqrt2 (quotient (+ x (quotient square x)) 2) x)))))) (sqrt2 square 0))) (test ((compose isqrt *) 12 75) 30) (test (map cadr '((a b) (d e) (g h))) '(b e h)) (test (map (lambda (n) (expt n n)) '(1 2 3 4 5)) '(1 4 27 256 3125)) (test (map + '(1 2 3) '(4 5 6)) '(5 7 9)) (test (let ((v (make-vector 5))) (for-each (lambda (i) (vector-set! v i (* i i))) '(0 1 2 3 4)) v) '#(0 1 4 9 16)) (test (force (delay (+ 1 2))) 3) (test (let ((p (delay (+ 1 2)))) (list (force p) (force p))) '(3 3)) (define a-stream (letrec ((next (lambda (n) (cons n (delay (next (+ n 1))))))) (next 0))) (define head car) (define tail (lambda (stream) (force (cdr stream)))) (test (head (tail (tail a-stream))) 2) (define count 0) (define p (delay (begin (set! count (+ count 1)) (if (> count x) count (force p))))) (define x 5) (test (force p) 6) (test (begin (set! x 10) (force p)) 6) (test (call-with-current-continuation (lambda (exit) (for-each (lambda (x) (if (negative? x) (exit x))) '(54 0 37 -3 245 19)) #t)) -3) (define list-length (lambda (obj) (call-with-current-continuation (lambda (return) (letrec ((r (lambda (obj) (cond ((null? obj) 0) ((pair? obj) (+ (r (cdr obj)) 1)) (else (return #f)))))) (r obj)))))) (test (list-length '(1 2 3 4)) 4) (test (list-length '(a b . c)) #f) ; === End of R4RS tests === (cond ((zero? Errors) (display "Everything fine!")) (else (display Errors) (if (> Errors 1) (display " errors.") (display " error.")))) (display #\newline) (if (file-exists? testfile) (delete-file testfile)) s9/util/libtest.scm000644 001751 001751 00000070302 13201114743 014146 0ustar00nmhnmh000000 000000 ; Automatically generated test suite, ; See libtest.sh for details. (load-from-library "syntax-rules.scm") (define Errors 0) (define (check src expr result) ; (write src) (display " ==> ") (write expr) (newline) (if (not (equal? expr result)) (begin (write src) (display " FAILED!") (newline) (display "Expected: ") (write result) (newline) (display "But got: ") (write expr) (newline) (set! Errors (+ 1 Errors))))) (define-syntax %test (syntax-rules (==>) ((_) #t) ((_ expr ==> result) (check 'expr expr 'result)) ((_ expr ==> result . more) (begin (check 'expr expr 'result) (%test . more))))) (load-from-library "adjoin.scm") (%test (adjoin 'x '(a b c)) ==> (x a b c) (adjoin 'c '(a b c)) ==> (a b c) ) (load-from-library "amb.scm") (%test (begin (amb-reset) (let ((collect (amb-collector))) (let ((x (amb 4 1 7))) (let ((y (amb 6 8 2))) (let ((z (amb 5 3 9))) (collect > x y z)))))) ==> ((7 6 3) (7 6 5)) ) (load-from-library "amk.scm") (%test (run* (q) (fresh (h t) (== q (list h t)) (appendo h t '(1 2 3)))) ==> ((() (1 2 3)) ((1) (2 3)) ((1 2) (3)) ((1 2 3) ())) ) (load-from-library "and-letstar.scm") (%test (and-let* ((a '((x . 1))) (a (assq 'x a))) (cdr a)) ==> 1 ; (and-let* ((a '((x . 1))) (a (assq 'z a))) (cdr a)) ==> #f ) (load-from-library "appendb.scm") (%test (let ((a (list 1 2 3))) (append! a (list 4 5 6) 'end) a) ==> (1 2 3 4 5 6 . end) ) (load-from-library "array.scm") (%test (let ((a (make-array 3 3 3))) (array-set! a 1 1 1 'foo) (array-ref a 1 1 1)) ==> foo ; (let ((a (array (array 1 2 3 4) (array 3 4 5 6) (array 5 6 7 8)))) (list (array-rank a) (array-dimensions a))) ==> (2 (3 4)) ) (load-from-library "assp.scm") (%test (assp char=? #\b '((#\a . 1) (#\b . 2))) ==> (#\b . 2) ) (load-from-library "basename.scm") (%test (basename "/foo/bar/baz") ==> "baz" (basename "/goo/bar.Z" ".Z") ==> "bar" ) (load-from-library "bitops.scm") (%test (bit0 123 456) ==> 0 (bit* 127 99) ==> 99 (bit+ 63 64) ==> 127 (bita 123 456) ==> 123 (bitb 123 456) ==> 456 (bitsl 123 1) ==> 246 ) (load-from-library "bitwise-ops.scm") (%test (bitwise-clear #b1010 #b1100) ==> #b0000 (bitwise-not-or #b1010 #b1100) ==> #b0001 (bitwise-and-c2 #b1010 #b1100) ==> #b0010 (bitwise-c2 #b1010 #b1100) ==> #b0011 (bitwise-and-c1 #b1010 #b1100) ==> #b0100 (bitwise-c1 #b1010 #b1100) ==> #b0101 (bitwise-xor #b1010 #b1100) ==> #b0110 (bitwise-not-and #b1010 #b1100) ==> #b0111 (bitwise-and #b1010 #b1100) ==> #b1000 (bitwise-not-xor #b1010 #b1100) ==> #b1001 (bitwise-1 #b1010 #b1100) ==> #b1010 (bitwise-or-c2 #b1010 #b1100) ==> #b1011 (bitwise-2 #b1010 #b1100) ==> #b1100 (bitwise-or-c1 #b1010 #b1100) ==> #b1101 (bitwise-or #b1010 #b1100) ==> #b1110 (bitwise-set #b1010 #b1100) ==> #b1111 (bitwise-shift-left 1 10) ==> 1024 (bitwise-shift-right 10 1) ==> 5 ) (load-from-library "catch.scm") (%test (let ((v #f)) (let ((r (catch 'foo (set! v 0) (throw 'foo 1) (set! v 2) 3))) (list v r))) ==> (0 1) ) (load-from-library "cdf.scm") (%test (cdf 0) ==> 0.5 ) (load-from-library "char-canvas.scm") (%test (let ((c (make-canvas 10 5 10 10))) (canvas-plot-line c 0 9 9 0 #\#) (canvas-plot-line c 0 0 9 9 #\*) (canvas-dump c)) ==> #("## **" " ## ** " " ** " " ** ## " "** ##") ) (load-from-library "choose.scm") (%test (choose 23 1) ==> 23 (choose 23 2) ==> 253 (choose 23 3) ==> 1771 ) (load-from-library "collect.scm") (%test (collect eq? '(a a a b c c)) ==> ((a a a) (b) (c c)) (collect < '(1 2 3 3 4 5 4)) ==> ((1 2 3) (3 4 5) (4)) ) (load-from-library "combine.scm") (%test (combine 2 '(a b c)) ==> ((a b) (a c) (b c)) (combine* 2 '(a b c)) ==> ((a a) (a b) (a c) (b b) (b c) (c c)) ) (load-from-library "cond-expand.scm") (%test (cond-expand (s9fes (cons 1 2))) ==> (1 . 2) (cond-expand (foo (cons 1 2)) (else (+ 1 2))) ==> 3 ) (load-from-library "count.scm") (%test (count '(a (b (c)) d . e)) ==> 5 ) (load-from-library "define-structure.scm") (%test (begin (define-structure point (x 0) (y 0) (color #f)) (let ((p (make-point))) (point-set-color! p 'yellow) (list (point? p) (point-color p)))) ==> (#t yellow) ) (load-from-library "depth.scm") (%test (depth '(a (b (c d (e))))) ==> 4 ) (load-from-library "dirname.scm") (%test (dirname "/foo/bar/baz") ==> "/foo/bar" (dirname "foo/bar") ==> "foo" (dirname "foo/bar/") ==> "foo" (dirname "/foo") ==> "/" (dirname "/") ==> "/" (dirname "foo") ==> "." ) (load-from-library "duplicates.scm") (%test (dupp = '(1 2 3 1 2)) ==> (1 2) (duplicates '((1) (2) (1))) ==> ((1)) (dupv '(#\a #\b #\a #\c)) ==> (#\a) (dupq '(a b c d a c e f c)) ==> (a c) ) (load-from-library "equal-cip.scm") (%test (equal-ci? '(#\A ("b")) '(#\a ("B"))) ==> #t ) (load-from-library "erf.scm") (%test (erf 0) ==> 0.0 ) (load-from-library "exists.scm") (%test (exists < '(9 1) '(8 2) '(7 3)) ==> #t ; because (< 1 2 3) ) (load-from-library "explode.scm") (%test (explode 'supernova) ==> (s u p e r n o v a) ) (load-from-library "factor.scm") (%test (factor 24) ==> ((3 1) (2 3)) ) (load-from-library "factorial.scm") (%test (factorial 30) ==> 265252859812191058636308480000000 ) (load-from-library "filter.scm") (%test (filter number? '(a 1 b 2 c 3)) ==> (1 2 3) ) (load-from-library "flatten.scm") (%test (flatten '(a (b ((c) d . e)))) ==> (a b c d e) ) (load-from-library "fluid-let-sr.scm") (%test (let ((a 0)) (let ((f (lambda () a))) (fluid-let ((a 1)) (f)))) ==> 1 ) (load-from-library "fluid-let.scm") (%test (let ((a 0)) (let ((f (lambda () a))) (fluid-let ((a 1)) (f)))) ==> 1 ) (load-from-library "for-all.scm") (%test (for-all < '(1 7) '(2 8) '(3 9)) ==> #t ; because (< 1 2 3) and (< 7 8 9) ) (load-from-library "format-time.scm") (%test (format-time "~w ~4y-~@m-~2d ~2h:~2m:~2s" '(1 2009 3 9 8 53 20)) ==> "Tue 2009-Mar-09 08:53:20" ) (load-from-library "get-prop.scm") (%test (get-prop '() 'foo) ==> #f (put-prop '() 'foo 42) ==> (foo 42) (get-prop '(foo 42) 'foo) ==> 42 (rem-prop '(foo 42) 'foo) ==> () ) (load-from-library "group.scm") (%test (group '(1 2 3 4 5) 2) ==> ((1 2) (3 4) (5)) (group '(1 2 3 4 5) 5) ==> ((1 2 3 4 5)) ) (load-from-library "hash-table.scm") (%test (let ((h (make-hash-table))) (hash-table-set! h "key" 'value) (hash-table-ref h "key")) ==> (value) ) (load-from-library "hof.scm") (%test ((complement pair?) '(1 2 3)) ==> #f ((complement eq?) 'foo 'bar) ==> #t ; ((compose car cdr) '(1 2 3)) ==> 2 ((compose list reverse list) 1 2 3) ==> ((3 2 1)) ; ((const (+ 1 2))) ==> 3 ((const (+ 1 2)) 3 4 5) ==> 3 ; ((curry + 1) 9) ==> 10 ((curry map list) '(1 2 3)) ==> ((1) (2) (3)) ; ((curry - 1) 10) ==> -9 ((curryr - 1) 10) ==> 9 ; ((fork < car) '(1 . a) '(2 . b) '(3 . c)) ==> #t ((fork append reverse) '(3 2 1) '(6 5 4)) ==> (1 2 3 4 5 6) ) (load-from-library "htmlify-char.scm") (%test (htmlify-char #\<) ==> "<" (htmlify-string "<&>") ==> "<&>" ) (load-from-library "hyper.scm") (%test (hyper 4 3 3) ==> 7625597484987 ) (load-from-library "id.scm") (%test (true) ==> #t (false 1 2 3) ==> #f (id 'whatever) ==> whatever ) (load-from-library "implode.scm") (%test (implode '(b l a c k h o l e)) ==> blackhole ) (load-from-library "integer-sqrt.scm") (%test (integer-sqrt 10) ==> 3 ) (load-from-library "integer-to-binary-string.scm") (%test (integer->binary-string 123 8) ==> "01111011" (binary-string->integer "01111011") ==> 123 (number-of-bits 127) ==> 7 ) (load-from-library "intersection.scm") (%test (intersection '(v w x) '(w x y) '(x y z)) ==> (x) ) (load-from-library "iota.scm") (%test (iota 7) ==> (1 2 3 4 5 6 7) (iota 17 21) ==> (17 18 19 20 21) (iota* 17 21) ==> (17 18 19 20) (iota* 1 1) ==> () ) (load-from-library "keyword-value.scm") (%test (keyword-value '(foo 1 bar 2) 'bar) ==> 2 (keyword-value '(foo 1) 'bar 0) ==> 0 ; (accept-keywords "test" '(foo 1 bar 2) '(foo bar)) ==> #t ) (load-from-library "leap-yearp.scm") (%test (leap-year? 2000) ==> #t (leap-year? 2003) ==> #f ) (load-from-library "letcc.scm") (%test (let/cc exit (letrec ((f (lambda (x) (cond ((null? x) 0) ((pair? x) (+ 1 (f (cdr x)))) (else (exit 'foo)))))) (f '(1 2 3 . 4)))) ==> foo ) (load-from-library "letrecstar.scm") (%test (letrec* ((a (lambda () (lambda () 1))) (b (a))) (b)) ==> 1 ) (load-from-library "list-copy.scm") (%test (list-copy '(foo bar baz)) ==> (foo bar baz) ) (load-from-library "list-to-set.scm") (%test (list->set '(a b c b c)) ==> (a b c) ) (load-from-library "listq.scm") (%test (listq a (b c) d) ==> (a (b c) d) ) (load-from-library "loutify-char.scm") (%test (loutify-char #\") ==> "\"\\\"\"" (loutify-string "\"x\"") ==> "\"\\\"x\\\"\"" ) (load-from-library "make-partitions.scm") (%test (make-partitions 4) ==> ((4) (3 1) (2 2) (2 1 1) (1 1 1 1)) ) (load-from-library "matcher.scm") (%test (begin (define-matcher len (() => 0) ((_ . x) => (+ 1 (len x)))) (len '(a b c d e f))) ==> 6 ; (let-matcher how-many ((nil => 0) (_ @ more => (+ 1 (apply how-many more)))) (how-many 1 2 3 4 5)) ==> 5 ; (let-matcher appnd ((() x => x) ((h . t) x => (cons h (appnd t x)))) (appnd '(a b c) '(d e f))) ==> (a b c d e f) ) (load-from-library "mean.scm") (%test (mean '(1 2 3 4 5 6)) ==> 3.5 ) (load-from-library "median.scm") (%test (mean '(1 2 3 4 5 6)) ==> 3.5 ) (load-from-library "memoize.scm") (%test (letrec ((fib (memoize (lambda (x) (if (< x 2) 1 (+ (fib (- x 1)) (fib (- x 2)))))))) (fib 100)) ==> 573147844013817084101 ) (load-from-library "memp.scm") (%test (memp char=? #\b '(#\a #\b #\c)) ==> (#\b #\c) ) (load-from-library "merge.scm") (%test (merge < '(1 3 5) '(2 4 6)) ==> (1 2 3 4 5 6) (merge < '(1 5 3) '(2 4 6)) ==> (1 2 5 3 4 6) (merge < '(3) '(1 2 4 5)) ==> (1 2 3 4 5) ) (load-from-library "mergesort.scm") (%test (mergesort <= '(5 3 7 9 1)) ==> (1 3 5 7 9) ) (load-from-library "mode.scm") (%test (mode '(1 2 3 3 4 5 5 6)) ==> (3 5) ) (load-from-library "name-to-file-name.scm") (%test (name->file-name "sys:stat-pipe?") ==> "sys_stat-pipep" (name->file-name "a->b") ==> "a-to-b" (name->file-name "*foo*") ==> "starfoostar" ) (load-from-library "package.scm") (%test (begin (package bar (:export foo2 foo3) (:make-aliases) (define (foo-maker n x) (if (zero? n) (lambda () x) (foo-maker (- n 1) (cons n x)))) (define foo2 (foo-maker 2 '())) (define foo3 (foo-maker 3 '()))) (list (bar:foo2) (foo3))) ==> ((1 2) (1 2 3)) ) (load-from-library "partition.scm") (%test (partition even? '(1 2 3 4 5)) ==> ((2 4) (1 3 5)) ) (load-from-library "permute.scm") (%test (permute 2 '(a b c)) ==> ((a b) (b a) (a c) (c a) (b c) (c b)) ; (permute* 2 '(a b c)) ==> ((a a) (a b) (a c) (b a) (b b) (b c) (c a) (c b) (c c)) ) (load-from-library "position.scm") (%test (position '(bar) '((foo) (bar) (baz))) ==> 1 (posv 4 '(0 1 2 3 4 5 6)) ==> 4 (posq 'foo '(foo bar baz)) ==> 0 (posp (lambda (x y) (= x (car y))) 2 '((0 . a) (1 . b) (2 . c))) ==> 2 ) (load-from-library "programp.scm") (%test (program? '(let ((x 1)) (cons x x))) ==> #t ) (load-from-library "proper-timep.scm") (%test (proper-time? '(3 1970 1 1 0 0 0)) ==> #t ) (load-from-library "quartile.scm") (%test (quartile '(1 2 3 4 5 6 7 )) ==> (2 4 6) ) (load-from-library "queue.scm") (%test (let ((q (make-queue))) (for-each (lambda (x) (queue! q x)) '(a b c d e)) (unqueue* q)) ==> (a ((e) b c d e)) ) (load-from-library "quicksort.scm") (%test (quicksort <= '(5 3 7 9 1)) ==> (1 3 5 7 9) ) (load-from-library "random-sort.scm") (%test (random-sort '(1 2 3 4 5)) ==> (2 3 5 1 4) ) (load-from-library "random.scm") (%test (list (random 100) (random 100) (random 100)) ==> (5 47 68) ) (load-from-library "range.scm") (%test (range '(1 2 3 4 5)) ==> (1 5) ) (load-from-library "rb-tree.scm") (%test (let ((tree (fold-left (lambda (t k) (rbt-insert t k (make-string k #\x))) (make-rbt <) '(1 2 3 4 5 6 7)))) (rbt-find tree 5)) ==> "xxxxx" ) (load-from-library "read-from-string.scm") (%test (read-from-string " (this \"is\" #(a) (list)) ; comment") ==> ((this "is" #(a) (list))) ; (read-from-string " (this \"is\" #(a) (list)) more text") ==> ((this "is" #(a) (list)) . " more text") ; (read-from-string ")") ==> "read-from-string: unexpected closing parenthesis" ; (read-from-string "#") ==> "unreadable expression #" ; (read-from-string "#" 'convert-unreadable #t) ==> ("#") ) (load-from-library "read-line.scm") (%test (with-input-from-file "lib/read-line.scm" read-line) ==> "; Scheme 9 from Empty Space, Function Library" ) (load-from-library "records.scm") (%test (record-ref (record (list 'name "Foo") (list 'value 31415)) 'name) ==> "Foo" ; (equal? (record (list 'name "Foo") (list 'value 31415)) (record (list 'value 31415) (list 'name "Foo"))) ==> #t ) (load-from-library "regex.scm") (%test (re-match (re-comp "^a[1-9]*z$") "a1289z") ==> ((0 6)) (re-match (re-comp "a[1-9]+z") "___a123z___") ==> ((3 8)) (re-match (re-comp "a[^1-9]+z") "a123z") ==> #f (re-match (re-comp "[1-9]*") "__1__") ==> ((2 3)) (re-match (re-comp "[1-9]*") "_____") ==> () ; (re-match (re-comp "f\\(.\\)\\(.\\)bar") "foobar") ==> ((0 6) (1 2) (2 3)) ; (re-match (re-comp "a\\(.\\)a") "aba_aca_ada" 'all) ==> (((0 3) (1 2)) ((4 7) (5 6)) ((8 11) (9 10))) ; (re-subst (re-comp "\\([0-9]+\\)\\.\\([0-9]+\\)\\.") "_01.1._31.12._" "\\2/\\1" 'all) ==> "_1/01_12/31_" ) (load-from-library "remove.scm") (%test (remp number? '(a 1 b 2 c 3)) ==> (a b c) (remove '(b) '(a (b) (c) (b))) ==> (a (c)) (remq 'b '(a b c b d)) ==> (a c d) (remv 3 '(3 1 2 3 1)) ==> (1 2 1) ) (load-from-library "replace.scm") (%test (replace '(x) '(y) '(lambda (x) y)) ==> (lambda (y) y) ) (load-from-library "set-difference.scm") (%test (set-difference '(a b c d e f) '(b d) '(a f)) ==> (c e) ) (load-from-library "setters.scm") (%test (let ((stack (list 0 2 3 4))) (let ((x (pop! stack))) (push! 1 stack) (list x stack))) ==> (0 (1 2 3 4)) ; (let ((x 1)) (dec! x) x) ==> 0 ; (let ((a 0) (b 0) (c 0)) (set-vars! a b c '(foo bar baz)) (list a b c)) ==> (foo bar baz) ; (let ((a 0) (b 1)) (swap! a b) (list a b)) ==> (1 0) ) (load-from-library "sieve.scm") (%test (sieve 20) ==> (2 3 5 7 11 13 17 19) ) (load-from-library "simple-modules.scm") (%test (begin ; Note: BEGIN is only needed for automatic testing (module math (define* (fact x) (if (= 0 x) 1 (* x (fact (- x 1)))))) (using math (fact) (fact 5))) ==> 120 ) (load-from-library "sort.scm") (%test (sort <= '(5 3 7 9 1)) ==> (1 3 5 7 9) ) (load-from-library "split-url.scm") (%test (split-url "ftp://example.org/foo.bar?a=1&b=2") ==> ("ftp" "example.org" "/foo.bar" "bar" (("a" . "1") ("b" . "2")) #f) ) (load-from-library "split.scm") (%test (split '(1 2 3 4)) ==> ((1 2) (3 4)) (split '(1 2 3 4 5)) ==> ((1 2 3) (4 5)) (split '()) ==> (() ()) ) (load-from-library "stddev.scm") (%test (stddev '(1 1 2 1 1)) ==> 0.4 ) (load-from-library "streams.scm") (%test (stream->list (append-streams (list->stream '(a b c)) (stream-iota 1 3))) ==> (a b c 1 2 3) (stream->list (filter-stream even? (stream-iota 1 10))) ==> (2 4 6 8 10) (stream->list (map-stream (lambda (x) (* 7 x)) (stream-iota 1 5))) ==> (7 14 21 28 35) (stream->list (stream-member (lambda (x) (= 27 x)) (stream-iota 1 30))) ==> (27 28 29 30) (stream-extract 5 (stream-iota 1 10000000)) ==> (1 2 3 4 5) ) (load-from-library "string-case.scm") (%test (string-upcase "Hello, World!") ==> "HELLO, WORLD!" (string-downcase "Hello, World!") ==> "hello, world!" ) (load-from-library "string-digest.scm") (%test (string-digest "hello") ==> 2107915172 ) (load-from-library "string-expand.scm") (%test (let ((tab (integer->char 9))) (string-expand (string #\x tab #\y))) ==> "x y" ) (load-from-library "string-find-last.scm") (%test (string-find-last "a" "aaaaa") ==> "a" (string-ci-find-last "A" "ab ac") ==> "ac" (string-find-last "ax" "ab ac") ==> #f (string-find-last-word "a" "ab a c") ==> "a c" (string-find-last-word "a" "ab ac") ==> #f ) (load-from-library "string-find.scm") (%test (string-find "ein" "gemeinsam") ==> "einsam" (string-find "people" "democracy") ==> #f (string-find-word "me" "test me") ==> "me" (string-find-word "me" "testme") ==> #f ) (load-from-library "string-last-position.scm") (%test (string-last-position "a" "aaaaa") ==> 4 (string-ci-last-position "A" "ab ac") ==> 3 (string-last-position "ax" "ab ac") ==> #f (string-last-word-position "a" "ab a c") ==> 3 (string-last-word-position "a" "ab ac") ==> #f ) (load-from-library "string-map.scm") (%test (string-map char-downcase "HELLO") ==> "hello" (let ((s (string-copy "HELLO!"))) (string-map! char-downcase s) s) ==> "hello!" ) (load-from-library "string-parse.scm") (%test (string-parse " ?" " to be or not to be? ") ==> ("to" "be" "or" "not" "to" "be") ) (load-from-library "string-position.scm") (%test (string-position "ein" "gemeinsam") ==> 3 (string-position "people" "democracy") ==> #f (string-word-position "me" "test me") ==> 5 (string-word-position "me" "testme") ==> #f ) (load-from-library "string-prefixeqp.scm") (%test (string-prefix=? "foo" "foobar") ==> #t (string-prefix=? "foo" "fubar") ==> #f ) (load-from-library "string-reverse.scm") (%test (string-reverse "rats live on no evil star") ==> "rats live on no evil star" ) (load-from-library "string-scan.scm") (%test (string-scan #\y "xyz") ==> 1 ) (load-from-library "string-split.scm") (%test (string-split #\: "a::b:c:") ==> ("a" "" "b" "c" "") ) (load-from-library "string-translate.scm") (%test (string-translate "a:b:c" ":" "-") ==> "a-b-c" ; (string-translate "hello, world!" "abcdefghijklmnopqrstuvwxyz" "nopqrstuvwxyzabcdefghijklm") ==> "uryyb, jbeyq!" ) (load-from-library "string-unsplit.scm") (%test (string-unsplit #\: '("" "a" "b" "" "c")) ==> ":a:b::c" ) (load-from-library "sublist.scm") (%test (sublist '(a b c d e) 2 4) ==> (c d) (sublist '(a b c d e) 2 2) ==> () ) (load-from-library "subsetp.scm") (%test (subset? '(a) '(a b) '(a b) '(a b c d)) ==> #t (subset? '(a b c)) ==> #t ) (load-from-library "substitute.scm") (%test (substitute '(* (+ 5 7) 9) '(((+ 5 7) . 12))) ==> (* 12 9) ) (load-from-library "subvector.scm") (%test (subvector '#(a b c d e) 2 4) ==> #(c d) (subvector '#(a b c d e) 2 2) ==> #() ) (load-from-library "sum.scm") (%test (sum 2 5) ==> 14 ) (load-from-library "symbols.scm") (%test (s9fes-syntax-objects) ==> () ) (load-from-library "t-sort.scm") (%test (t-sort-net eq? '((dressed shoes hat) (shoes socks pants) (pants underpants) (hat pullover) (pullover shirt undershirt) (shirt undershirt) (underpants))) ==> (socks underpants pants shoes undershirt shirt pullover hat dressed) ; (let ((db '((a b c) (b u) (c v) (u x) (v y) (w z)))) (t-sort eq? 'a (lambda (x) (assq x db)) 'top-down #t 'reverse #t)) ==> (a b c u v x y) ; (t-sort-net eq? '((a b c d))) ==> (b c d a) (t-sort-net eq? '((a b c d)) 'strict #t) ==> #f (t-sort-net eq? '((a b) (b a))) ==> #f (t-sort-net eq? '((foo foo)) 'check #t) ==> (cyclic . foo) ) (load-from-library "tagbody.scm") (%test (let ((x 10) (x0 1) (x1 1)) (tagbody fib (if (zero? x) (go end)) (let ((t x1)) (set! x1 (+ x0 x1)) (set! x0 t)) (set! x (- x 1)) (go fib) end) x1) ==> 144 ) (load-from-library "take.scm") (%test (take '(foo bar baz) 0) ==> () (take '(foo bar baz) 1) ==> (foo) (take '(foo bar baz) 3) ==> (foo bar baz) ) (load-from-library "time-ops.scm") (%test (time-add '(0 2010 10 06 12 30 00) '(10 7 30 0)) ==> (5 2010 10 16 20 0 0) (time-difference '(0 2010 10 06 12 30 00) '(5 2010 10 16 20 00 00)) ==> (10 7 30 0) (time-after? '(5 2010 10 16 20 00 00) '(0 2010 10 06 12 30 00)) ==> #t ) (load-from-library "time-to-unix-time.scm") (%test (time->unix-time '(6 2010 4 25 7 1 19)) ==> 1272178879 ) (load-from-library "transpose.scm") (%test (transpose '((1 2 3) (4 5 6))) ==> ((1 4) (2 5) (3 6)) ) (load-from-library "tree-copy.scm") (%test (tree-copy '(((a . b) (c . d)) (e . f))) ==> (((a . b) (c . d)) (e . f)) ; (let* ((tree (list (string #\A))) (tree2 (tree-copy tree)) (tree3 (tree-copy tree 'with-atoms))) (string-set! (car tree) 0 #\X) (list tree2 tree3)) ==> (("X") ("A")) ) (load-from-library "tree-equalp.scm") (%test (tree-equal? (lambda (x y) #t) '(((a . b) (c . d)) (e . f)) '(((1 . 2) (3 . 4)) (5 . 6))) ==> #t ; (tree-equal? eqv? '((1 . 2) (3 . 4)) '((1 . 2) (3 4))) ==> #f ) (load-from-library "tree-map.scm") (%test (tree-map number? list '((a . 1) (b . 2))) ==> ((a . (1)) (b . (2))) (tree-map (lambda (x) (and (pair? x) (string? (car x)) (string? (cdr x)))) (lambda (x) (string-append (car x) (cdr x))) '(("foo" . "bar") ("bar" . "baz"))) ==> ("foobar" "barbaz") ) (load-from-library "type-case.scm") (%test (type-of type-of) ==> procedure ; (let ((x '#(1 2 3)) (i 0)) (type-case x ((string) (string-ref x i)) ((vector) (vector-ref x i)) (else x))) ==> 1 ) (load-from-library "union.scm") (%test (union '(v w x) '(w x y) '(x y z)) ==> (v w x y z) ) (load-from-library "unix-time-to-time.scm") (%test (unix-time->time 1272178879) ==> (6 2010 4 25 7 1 19) ) (load-from-library "unsort.scm") (%test (unsort '(1 2 3 4 5) 1) ==> (1 3 5 4 2) ) (load-from-library "url-decode.scm") (%test (url-decode "%46%4F%4FBAR") ==> "FOOBAR" ) (load-from-library "variance.scm") (%test (variance '(1 1 2 1 1)) ==> 0.16 ) (load-from-library "vector-map.scm") (%test (vector-map + '#(1 2 3) '#(4 5 6)) ==> #(5 7 9) (let ((v (vector 1 2 3))) (vector-map! - v) v) ==> #(-1 -2 -3) ) (load-from-library "when.scm") (%test (when (= 1 1) 'foo 'bar 'baz) ==> baz (unless (= 1 2) 'foo 'bar 'baz) ==> baz ) (load-from-library "while.scm") (%test (let ((x 0) (y 1)) (while (< x 10) (set! y (* 2 y)) (set! x (+ 1 x))) y) ==> 1024 ) (load-from-library "write-to-string.scm") (%test (write-to-string '(a 1 #\c #(v) #t "str" "\"s\"" (a . d))) ==> "(a 1 #\\c #(v) #t \"str\" \"\\\"s\\\"\" (a . d))" ; (display-to-string '(a 1 #\c #(v) #t "str" "\"s\"" (a . d))) ==> "(a 1 c #(v) #t str \"s\" (a . d))" ) (load-from-library "format.scm") (%test (format #f "~A ~:* ~S" '(#\c "s")) ==> "(c s) (#\\c \"s\")" ; (format #f "~20,'_,',,3:D" 123456789) ==> "_________123,456,789" ; (format #f "~@{ ~A,~A ~}" 'a 1 'b 2 'c 3) ==> " a,1 b,2 c,3 " ) (load-from-library "pretty-print.scm") (%test (pp-string '("(let ((a 1) (b 2))" "(cons a b))")) ==> ("(let ((a 1)" " (b 2))" " (cons a b))") ) (load-from-library "prolog.scm") (%test (begin (! (man socrates)) (:- (mortal ?x) (man ?x)) (query '(mortal ?who))) ==> (((who . socrates))) ) (load-from-library "queens.scm") (%test (queens 4) ==> ((2 0 3 1) (1 3 0 2)) ) (load-from-library "s9sos.scm") (%test (begin (define-generic mul) ; (define-method (mul (x ) (y )) (* x y)) ; (define-method (mul (x ) (a )) (map (lambda (i) (* i x)) a)) ; (define-method (mul (a ) (x )) (map (lambda (i) (* i x)) a)) ; (define-method (mul (a ) (b )) (map * a b)) ; (list (mul 5 7) (mul 2 '(1 2 3)) (mul '(1 2 3) 2) (mul '(1 2 3) '(4 5 6)))) ==> (35 (2 4 6) (2 4 6) (4 10 18)) ; ; Don't do this! Generic application takes ages. (begin (define-generic len) (define-method (len (x )) 0) (define-method (len (x )) (+ 1 (len (cdr x)))) (len '(1 2 3 4 5))) ==> 5 ) (load-from-library "scm2html.scm") (%test (scm2html 'input-string: "'()") ==> (("c" #f quote 0 ()) "'()") ) (load-from-library "string-locate.scm") (%test (string-locate "test" "This is a test string") ==> 10 (string-locate "TEST" "This is a test string") ==> #f ) (load-from-library "zebra.scm") (%test (zebra) ==> (((norwegian kools _.0 fox yellow) (ukrainian chesterfields tea horse blue) (englishman oldgolds milk snails red) (spaniard luckystrikes orangejuice dog ivory) (japanese parliaments coffee zebra green))) ) (if (= 0 Errors) (begin (display "Everything fine!") (newline))) s9/util/libtest.sh000644 001751 001751 00000003072 12550520617 014005 0ustar00nmhnmh000000 000000 #!/bin/sh # Scheme 9 from Empty Space # By Nils M Holm, 2008-2012 # Generate Library Test Suite testfile=util/libtest.scm trap ' cleanup exit 1 ' 1 2 3 15 cleanup() { rm -f $testfile } cat >$testfile < ") (write expr) (newline) (if (not (equal? expr result)) (begin (write src) (display " FAILED!") (newline) (display "Expected: ") (write result) (newline) (display "But got: ") (write expr) (newline) (set! Errors (+ 1 Errors))))) (define-syntax %test (syntax-rules (==>) ((_) #t) ((_ expr ==> result) (check 'expr expr 'result)) ((_ expr ==> result . more) (begin (check 'expr expr 'result) (%test . more))))) EOT cases="lib/*.scm contrib/*.scm" if echo '*extensions*' | ./s9 | grep sys-unix >/dev/null; then cases="$cases ext/unix/*.scm" fi for f in $cases; do if grep '^; Example: ' $f >/dev/null 2>&1; then echo "(load-from-library \"`basename $f`\")" >>$testfile echo "(%test" >>$testfile sed -ne '/^; Example: /,/^$/p' <$f | \ sed -e '/^$/d' | \ sed -e 's/^;..........//' >>$testfile echo ")" >>$testfile echo "" >>$testfile fi done cat >>$testfile < @DESC@ : S9fES : T3X.ORG
http://t3x.org/s9fes/@BASE@

@DESC@

s9/util/descriptions000644 001751 001751 00000024014 13041747260 014434 0ustar00nmhnmh000000 000000 adjoin.scm|adjoin|-|Add elements to sets advgen.scm|-|Generate HTML text adventures|- amb.scm|-|McCarthy's ambivalence operator|- amk.scm|-|Another Micro Kanren|Embed logic programming into Scheme and-letstar.scm|and-let*|-|Guarded LET* append-to-output-file.scm|append-to-output-file|-|Open files for appending appendb.scm|append!|-|Append lists destructively array.scm|-|Array type and operations|- assp.scm|assp|-|Find first member of an alist satisfying a predicate basename.scm|basename|-|Extract the base name from a path bitops.scm|-|Fast small-magnitude bit operators|- bitwise-ops.scm|-|Bitwise logic operators|- bottles.scm|bottles|-|Generate the 99-bottles lyrics using syntax-rules c2html.scm|c2html|-|Render C code in HTML c2html1.scm|-|C2HTML command line wrapper|- catch.scm|catch / throw|-|Handle exceptions cdf.scm|cdf|-|Cumulative Distribution Function char-canvas.scm|-|Character-based canvas|- char-plot.scm|-|Character-based graph plotter|- check-descr.scm|-|Missing description ;-)|- choose.scm|choose|-|Compute binomial coefficients collect.scm|collect|-|Collect related elements from lists cols.scm|-|Format input in two columns|- combine.scm|combine|-|Generate combinations of sets cond-expand.scm|cond-expand|-|Simple feature-based conditional expansion config.scm|-|S9fES heap image configuration file|- count.scm|count|-|Count atomic members of pairs csv.scm|-|Comma-separated value (CSV) functions|- curses.scm|-|S9fES Curses interface|- data-structures.scm|-|Various data structures|- define-structure.scm|define-structure|-|Define structure types depth.scm|depth|-|Compute depth of an object dirname.scm|dirname|-|Extract the directory part of a path displaystar.scm|display*|-|Display multiple objects draw-tree.scm|draw-tree|-|Draw S-expressions in box notation dupes.scm|-|Find duplicate file names|- duplicates.scm|duplicates|-|Find duplicate members in lists edoc.scm.edoc|-|Embedded documentation processor|- equal-cip.scm|equal-ci?|-|Compare objects case-insensitively erf.scm|erf|-|Gauss error function exists.scm|exists|-|Existential quantifier explode.scm|explode|-|Explode symbols factor.scm|factor|-|Compute prime factors factorial.scm|factorial|-|Compute factorials filter.scm|filter|-|Extract objects from lists find-help-path.scm|find-help-path|-|Locate the S9fES online help pages find-help.scm|find-help|-|Search S9fES online help pages flatten.scm|flatten|-|Convert trees to flat lists fluid-let-sr.scm|fluid-let|using syntax-rules|Change values dynamically fluid-let.scm|fluid-let|using a low-level macro|Change values dynamically flush-output-port.scm|flush-output-port|-|Synchronize output ports for-all.scm|for-all|-|Universal quantifier format-test.scm|-|FORMAT test suite|- format-time.scm|format-time|-|Convert time specification to readable string format.scm|format|Common Lisp-style text formatter|- get-line.scm|get-line|-|Edit lines of text interactively get-prop.scm|get-prop, etc|-|Property list procedures graph-tools.scm|-|Graph (tree, DAG, etc) tools|- group.scm|group|-|Group lists in tuples hash-table.scm|-|Hash tables|- help.scm|-|Online help system|- hof.scm|-|Higher order functions (composition, partial application, etc)|- htmlify-char.scm|-|Convert text to HTML|- htmlify.scm|-|Convert plain text to HTML|- hyper.scm|hyper|-|Hyper operator id.scm|-|Identity, truth, and falsity functions|- implode.scm|implode|-|Implode lists to symbols inet-server.scm|inet-server|-|Run an internet server integer-sqrt.scm|integer-sqrt|-|Compute the integer part of a square root integer-to-binary-string.scm|-|Integer to binary string conversion|- intersection.scm|intersection|-|Intersection of sets io-tools.scm|-|I/O tools|- iota.scm|iota|-|Create numeric ranges keyword-value.scm|keyword-value|-|Extract keyword values from argument lists leap-yearp.scm|leap-year?|-|Check if a year is a leap year letcc.scm|let/cc|-|Bind current continuation letrecstar.scm|letrec*|-|Sequential LETREC libtest.scm|-|S9fES library test suite|- list-copy.scm|list-copy|-|Copy the spine of a list list-to-set.scm|list-\>set|-|Convert list to set list-tools.scm|-|List tools|- listq.scm|listq|-|Create list of quoted objects loutify-char.scm|-|Convert text to Lout input|- make-cats.scm|-|Create CATEGORIES.html file|- make-partitions.scm|make-partitions|-|Compute number-theoretic partitions matcher.scm|-|Pattern-based procedure dispatch|- math-tools.scm|-|Math tools|- mean.scm|mean|-|Arithmetic mean (average) median.scm|median|-|Statistical median (middle value) memoize.scm|-|Function memoization|- memp.scm|memp|-|Find first list member satisfying a predicate merge.scm|merge|-|Merge lists mergesort.scm|mergesort|-|Sort elements using mergesort mode-to-string.scm|mode-\>string|-|Convert Unix file mode to readable string mode.scm|mode|-|Statistical mode (most frequent values) of a sample name-to-file-name.scm|name-\>file-name|-|Convert names to safe file names ndf.scm|ndf|-|Normal Distribution Function (probability density) package.scm|-|First-class packages|- parse-optionsb.scm|-|Parse command line options|- partition.scm|partition|-|Partition lists permute.scm|permute|-|Generate permutations of sets plan9-tools.scm|-|Plan 9 system tools|- plan9.scm|-|S9fES Plan 9 interface|- position.scm|-|Find positions of list elements|- pretty-print.scm|-|Pretty printer|- procedures.scm|-|Collect procedure names from help files|- programp.scm|program?|-|Check Scheme program syntax prolog-test.scm|-|Tiny PROLOG sample program|- prolog.scm|-|Tiny PROLOG interpreter|- proper-timep.scm|proper-time?|-|Check whether a time specification is sound quartile.scm|quartile|-|Quartiles of a sample queens.scm|-|N-Queens puzzle (using AMK)|- queue.scm|-|Queue data structure and operations|- quicksort.scm|quicksort|-|Sort elements using Quicksort random-sort.scm|random-sort|-|Generate random permutations random.scm|random|-|Generate pseudo-random numbers range.scm|range|-|Range of a sample (minimal/maximal value) rb-tree.scm|-|Red-Black Trees|- read-file.scm|read-file|-|Read all lines of a text file read-from-string.scm|read-from-string|-|Read S-expression from string read-line.scm|read-line|-|Read lines from a text file realtest.scm|-|Real number tests|- records.scm|-|ML-style records|- regex.scm|-|Regular expression matcher|- remove.scm|remove|-|Remove members from lists replace.scm|replace|-|Replace members in pairs runtime-stats.scm|runtime-stats|-|Gather runtime statistics s9-real.scm|-|S9fES core library (real numbers)|- s9.scm|-|S9fES core library|- s9help.scm|-|Find and display S9fES help pages|- s9hts.scm|-|Hypertext server|- s9resolve.scm|-|Resolve S9fES library references|- s9sos.scm|-|S9fES Simple Object System|- s9symbols.scm|-|Extract S9 symbols from help pages|- scm2html.scm|-|Render Scheme code in HTML|- scm2html1.scm|-|SCM2HTML command line wrapper|- scmpp.scm|-|PRETTY-PRINT command line wrapper|- search-path.scm|search-path|-|Search for an executable in shell search path set-difference.scm|-|Difference between sets|- set-tools.scm|-|Set tools|- setters.scm|push!, inc!, set-vars!, ...|-|Inc!, swap!, push! and friends sieve.scm|sieve|-|Find prime numbers simple-modules.scm|-|Simple module syntax|- soccat.scm|-|Connect to remote systems|- sort.scm|sort|-|Sort lists spawn-command.scm|spawn-command|-|Spawn a child process spawn-shell-command.scm|spawn-shell-command|-|Spawn a shell command split-url.scm|split-url|-|Split an URL string into individual parts split.scm|split|-|Split a list into two srtest.scm|-|S9fES syntax-rules tests|- standard-error.scm|-|Write output to stderr descriptor|- stat-tools.scm|-|Statistics tools|- stddev.scm|stddev|-|Standard deviation streams.scm|-|Purely functional lazy streams|- string-case.scm|-|Convert strings to upper/lower case|- string-digest.scm|string-digest|-|Create digests of strings string-expand.scm|string-expand|-|Expand tabs to spaces string-find-last.scm|-|Simple string search (backward)|- string-find.scm|-|Simple string search (forward)|- string-last-position.scm|-|Find last position of substring|- string-locate.scm|-|Fast string search|- string-map.scm|-|Map procedures over strings|- string-parse.scm|string-parse|-|Tokenize strings string-position.scm|-|Find first position of substring|- string-prefixeqp.scm|string-prefix=?|-|Check string for prefix string-reverse.scm|string-reverse|-|Reverse strings string-scan.scm|string-scan|-|Find characters in strings string-split.scm|string-split|-|Split strings string-tools.scm|-|String tools|- string-translate.scm|string-translate|-|Translate characters string-unsplit.scm|string-unsplit|-|Concatenate strings sublist.scm|sublist|-|Extract sub-lists subsetp.scm|subset?|-|Test whether a set is a subset of another substitute.scm|substitute|-|Substitute values for symbols subvector.scm|subvector|-|Extract sub-vectors sum.scm|sum|-|Compute sums over ranges symbols.scm|-|Lists of R4RS and S9fES Scheme symbols|- syntax-extensions.scm|-|Syntax extensions|- syntax-rules.scm|syntax-rules|-|Generate syntax transformers systest.scm|-|S9fES Unix extension test suite|- t-sort.scm|t-sort|-|Topological sort tagbody.scm|tagbody|-|Common Lisp TAGBODY take.scm|take|-|Copy leftmost elements of a list test.scm|-|S9fES core test suite|- threads.scm|-|Cooperative multithreading|- time-ops.scm|-|Date and time operations|- time-to-unix-time.scm|time-\>unix-time|-|Convert Unix time to time spec time.scm|time|-|Measure execution time transpose.scm|transpose|-|Transpose matrixes tree-copy.scm|tree-copy|-|Copy cons structures tree-equalp.scm|tree-equal?|-|Compare cons structures tree-map.scm|tree-map|-|Map functions over trees type-case.scm|-|Type-based dispatch|- union.scm|union|-|Union of sets unix-time-to-time.scm|unix-time-\>time|-|Convert time spec to Unix time unix-tools.scm|-|Unix system tools|- unix.scm|-|S9fES Unix interface|- unsort.scm|unsort|-|Unsort lists url-decode.scm|url-decode|-|Decode URL-encoded strings variance.scm|variance|-|Variance vector-map.scm|-|Map procedures over vectors|- vector-tools.scm|-|Vector tools|- when.scm|-|Conditional evaluation without alternative|- while.scm|-|Unbounded looping constructs|- write-to-string.scm|write-to-string|-|Write S-expression to string zebra.scm|-|Zebra puzzle (using AMK)|- s9/util/dirtail000644 001751 001751 00000000105 11776510522 013353 0ustar00nmhnmh000000 000000

contact

s9/util/srtest.scm000644 001751 001751 00000006373 11444324524 014042 0ustar00nmhnmh000000 000000 ; Scheme 9 from Empty Space ; SYNTAX-RULES Test Suite ; By Nils M Holm, 2007-2010 (load-from-library "syntax-rules.scm") (define Errors 0) (define (fail expr result expected) (display "test failed: ") (write expr) (newline) (display "got result: ") (write result) (newline) (display "expected: ") (write expected) (newline) (set! Errors (+ 1 Errors))) (define (test3 expr result expected) ; (write expr) (display " => ") (write result) (newline) (if (not (equal? result expected)) (fail expr result expected))) (define-syntax (test form result) `(test3 ',form ,form ,result)) (define-syntax keyword (syntax-rules () ((_) '()))) (test (keyword) '()) (define-syntax iff (syntax-rules (then else) ((_ p then t) (and p t)) ((_ p then t else f) (cond (p t) (else f))))) (test (iff #t then 'foo) 'foo) (test (iff #f then 'foo) #f) (test (iff #t then 'foo else 'bar) 'foo) (test (iff #f then 'foo else 'bar) 'bar) (test (iff #f then (error "error")) #f) (test (iff #t then 'foo else (error "error")) 'foo) (test (iff #f then (error "error") else 'bar) 'bar) (define-syntax foo-syntax (syntax-rules () ((_ x) x) ((_ x y ...) (cons x (foo-syntax y ...))))) (test (foo-syntax 1 2 3 4 5) '(1 2 3 4 . 5)) (define-syntax bar-syntax (syntax-rules () ((_) '()) ((_ x ...) (list '(x x) ...)))) (test (bar-syntax) '()) (test (bar-syntax x) '((x x))) (test (bar-syntax x y) '((x x) (y y))) (test (bar-syntax x y z) '((x x) (y y) (z z))) (define-syntax rev-syntax (syntax-rules () ((_ () r) r) ((_ (a . d) r) (rev-syntax d (a . r))) ((_ x) (rev-syntax x ())))) (test (rev-syntax ()) '()) (test (rev-syntax (2 1 cons)) '(1 . 2)) (test (rev-syntax ('bar 'foo #t if)) 'foo) (define-syntax ell (syntax-rules () ((_ ((a b) ...) c ...) (list '((b a) ...) c ...)))) (test (ell ()) '(())) (test (ell () 0) '(() 0)) (test (ell ((1 2)) 3) '(((2 1)) 3)) (test (ell ((1 2) (3 4) (5 6)) 7) '(((2 1) (4 3) (6 5)) 7)) (test (ell ((1 2)) 3 4 5) '(((2 1)) 3 4 5)) (define-syntax false (syntax-rules () ((_ x y ...) (if x (list y ...) (if #f #f))))) (test (false #t 1 2 3) '(1 2 3)) (test (false #f 1 2 3) (if #f #f)) (define-syntax fluid-let (syntax-rules () ((_ () expr . exprs) (begin expr . exprs)) ((_ ((v1 a1) (v2 a2) ...) expr . exprs) (let ((outer-v v1)) (set! v1 a1) (fluid-let ((v2 a2) ...) (let ((r (begin expr . exprs))) (set! v1 outer-v) r)))))) (test (let ((x 0) (y 1) (z 2) (fx #f) (fy #f)) (fluid-let ((x -2) (y -1)) (set! fx x) (set! fy y)) (list fx fy x y z)) '(-2 -1 0 1 2)) (define-syntax foo-syntax (syntax-rules () ((_ x ...) (list #t x ... #f)))) (test (foo-syntax) '(#t #f)) (test (foo-syntax 1) '(#t 1 #f)) (test (foo-syntax 1 2 3) '(#t 1 2 3 #f)) (define-syntax local-foo (syntax-rules () ((_ x) (let ((local 0)) x)))) (test (let ((local 1)) (local-foo local)) 1) (cond ((zero? Errors) (display "Everything fine!")) (else (display Errors) (if (> Errors 1) (display " errors.") (display " error.")))) (display #\newline) s9/util/make-html000755 001751 001751 00000022556 13201114415 013605 0ustar00nmhnmh000000 000000 #!/bin/sh dumpdir=webdump update_only=no tmpfile=/tmp/mkhtml.$$ cleanup() { rm -f $tmpfile rm -f rpp rp_html exit } trap cleanup 1 2 3 usage() { echo "Usage: make-html [-u {scm|cee|txt|man|nah|dir}]" exit 1 } while [ "x$1" != "x" ]; do case x$1 in x-u) shift if [ "x$1" = "x" ]; then usage; fi update_only=$1 shift ;; x-r) shift if [ "x$1" = "x" ]; then usage; fi V=$1 export V shift ;; *) usage ;; esac done format_scm_files() { base=$1 shift files=$* for file in $files; do html=`basename $file`.html fname=$(basename $file) name=$(grep "^$fname|" util/descriptions | cut -f 2 -d "|") desc=$(grep "^$fname|" util/descriptions | cut -f 3 -d "|") oname=$dumpdir/`basename $fname`.html echo -n $oname' ...' if [ "x$name" = "x" ]; then echo -n " NO DESCRIPTION!" fi sed -e "s|@BASE@|$html|g" \ $tmpfile if [ "x$desc" != "x-" -a "x$name" != "x-" ] ; then sed \ -e "s|@DESC@|$name\ \  $desc|" \ -e "s|@TITLE@|$name\ \  $desc|" \ <$tmpfile >$oname elif [ "x$desc" != "x-" ] ; then sed -e "s|@DESC@|$desc|" \ -e "s|@TITLE@|$desc|" \ <$tmpfile >$oname else sed -e "s|@DESC@|$name|" \ -e "s|@TITLE@|$name|" \ <$tmpfile >$oname fi echo -n "

" >>$oname if [ "x$base" != "x" ]; then echo "Location: $base, " \ >>$oname fi sed -e "1,/^$/d" <$file | wc -l >>$oname echo " Lines

" >>$oname prog/scm2html1.scm -9x $file >>$oname cat util/libtail >>$oname echo " done" done } format_C_files() { base=$1 shift files=$* for file in $files; do html=`basename $file`.html fname=$(basename $file) oname=$dumpdir/`basename $fname`.html echo -n $oname' ...' sed -e "s|@BASE@|$html|g" \ $tmpfile if [ "x$base" = "x" ]; then sed -e "s/@DESC@/`basename $file`/" \ -e "s/@TITLE@/`basename $file`/" \ <$tmpfile >$oname else sed -e "s|@DESC@|$base/`basename $file`|" \ -e "s/@TITLE@/`basename $file`/" \ <$tmpfile >$oname fi echo -n "

" >>$oname sed -e "1,/^$/d" <$file | wc -l >>$oname echo " Lines

" >>$oname prog/c2html1.scm $file >>$oname cat util/libtail >>$oname echo " done" done } format_txt_files() { hrefs=no if [ "x$1" = "x-r" ]; then hrefs=yes; shift; fi base=$1 shift files=$* for file in $files; do html=`basename $file`.html oname=$dumpdir/`basename $file`.html echo -n $oname' ...' sed -e "s|@BASE@|$html|g" \ $tmpfile if [ "x$base" = "x" ]; then sed -e "s/@DESC@/`basename $file`/" \ -e "s/@TITLE@/`basename $file`/" \ <$tmpfile >$oname else sed -e "s|@DESC@|$base/`basename $file`|" \ -e "s/@TITLE@/`basename $file`/" \ <$tmpfile >$oname fi echo '
' >>$oname
		if [ $hrefs = yes ]; then
			prog/htmlify.scm -t $file | \
			sed -e 's/\(http:\/\/.*\)/\1<\/A>/' \
				>>$oname
		else
			prog/htmlify.scm -t $file >>$oname
		fi
		echo '
' >>$oname cat util/libtail >>$oname echo " done" done } format_man_pages() { hrefs=no if [ "x$1" = "x-r" ]; then hrefs=yes; shift; fi files=$* for file in $files; do html=`basename $file`.html ofile=$dumpdir/`basename $file`.html echo -n $ofile' ...' sed -e "s|@BASE@|$html|g" \ $tmpfile sed -e "s/@DESC@/`basename $file`/" \ -e "s/@TITLE@/`basename $file`/" \ <$tmpfile >$ofile echo '
' >>$ofile
		if [ $hrefs = yes ]; then
			nroff -mdoc -c $file | ./rpp -p html | \
			sed -e 's/\(http:\/\/.*\)\1<\/A>>$ofile
		else
			nroff -mdoc -c $file | ./rpp -p html >>$ofile
		fi
		echo '
' >>$ofile cat util/dirtail >>$ofile echo " done" done } naah() { base=$1; shift what=$1; shift files=$* for file in $files; do html=`basename $file`.html oname=$dumpdir/`basename $file`.html echo -n $oname' ...' sed -e "s|@BASE@|$html|g" \ $tmpfile if [ "x$base" = "x" ]; then sed -e "s/@DESC@/`basename $file`/" \ -e "s/@TITLE@/`basename $file`/" \ <$tmpfile >$oname else sed -e "s|@DESC@|$base/`basename $file`|" \ -e "s/@TITLE@/`basename $file`/" \ <$tmpfile >$oname fi echo '

Naah

' >>$oname echo "

This $what is not included here. Please" >>$oname echo ' download the archive' \ >>$oname echo ' to have a look at it.

' >>$oname cat util/dirtail >>$oname echo " done" done } dirlist() { dir=$1 ofile=$2 title=$3 echo -n $ofile' ...' if [ "x$dir" = "x." ]; then sed -e "s/@BASE@//" $tmpfile else sed -e "s|@BASE@|$dir.html|" \ $tmpfile fi sed -e "s/@DESC@/$title/" <$tmpfile >$ofile if [ "$4" = "about" ]; then sed -e 's/\$V/'"$V"'/g' >$ofile fi echo '
' >>$ofile
	(cd $dir; ls -l | grep -v "$dumpdir") | grep -v " edoc$" | awk '
		BEGIN { V=ENVIRON["V"] }
		{ if ($9 == "CATEGORIES.html")
			name=$9
		  else if ($9 == "s9fes-"V".tgz")
			name=$9
		  else if ($9 == "s9core-"V".tgz")
			name=$9
		  else if ($9 == "s9core.pdf")
			name=$9
		  else if ($9 == "MASCOT.png")
			name=$9
		  else if ($9 == "freebsd-port")
			name="http://www.freebsd.org/cgi/cvsweb.cgi/ports/lang/s9fes"
		  else
			name=$9".html"
		  if ($9 == "")
			print $0
		  else
			printf "%s %2s %3s %4s %7s %3s %2s %6s" \
				" %s\n", \
				$1, $2, $3, $4, $5, $6, $7, $8, name, $9
		}' >>$ofile
	echo '
' >>$ofile cat util/dirtail >>$ofile echo " done" } if [ $update_only = no -o $update_only = dir ]; then if [ $update_only = no ]; then make cdist && mv -f s9core-$V.tgz /tmp/s9core$$.tgz make dist s9 -f util/make-cats.scm fi if [ -d $dumpdir ]; then rm -f /tmp/s9core$$.tgz if [ $update_only = no ]; then echo -n "You may want to remove the $dumpdir" echo " directory first!" exit 1 fi else mkdir $dumpdir cp s9fes-$V.tgz MASCOT.png $dumpdir cp prog/edoc.css contrib/scheme.css contrib/ccode.css $dumpdir mv -f /tmp/s9core$$.tgz s9core-$V.tgz fi dirlist . $dumpdir/index.html "Scheme 9 from Empty Space" "about" dirlist lib $dumpdir/lib.html "lib\/" "" dirlist contrib $dumpdir/contrib.html "contrib\/" "" dirlist ext $dumpdir/ext.html "ext\/" "" dirlist ext/sys-unix $dumpdir/sys-unix.html "sys-unix\/" "" dirlist ext/sys-plan9 $dumpdir/sys-plan9.html "sys-plan9\/" "" dirlist ext/curses $dumpdir/curses.html "curses\/" "" dirlist ext/csv $dumpdir/csv.html "csv\/" "" dirlist prog $dumpdir/prog.html "prog\/" "" dirlist util $dumpdir/util.html "util\/" "" if [ $update_only = no ]; then mv -f CATEGORIES.html $dumpdir mv -f s9core-$V.tgz $dumpdir make fi fi if [ $update_only = no -o $update_only = txt ]; then format_txt_files "" ABOUT CHANGES LICENSE format_txt_files "" Makefile README TODO README.s9core format_txt_files "" configure _csums mkfile s9.1.txt s9core.txt format_txt_files lib lib/_template format_txt_files prog prog/adventure.adv prog/edoc.css format_txt_files prog prog/advgen.txt format_txt_files contrib contrib/scheme.css contrib/ccode.css format_txt_files contrib contrib/format.txt contrib/s9sos.txt format_txt_files util util/descriptions util/make-help-links format_txt_files util util/libtest.sh util/make-docs util/make-html format_txt_files util util/fix-help-files util/rp_html format_txt_files util util/s9.rc fi if [ $update_only = no -o $update_only = cee ]; then format_C_files "" s9.c s9core.c s9core.h s9import.h s9ext.h format_C_files sys-unix ext/sys-unix/unix.c format_C_files sys-plan9 ext/sys-plan9/plan9.c format_C_files sys-plan9 ext/sys-plan9/s9-ffi.c format_C_files sys-plan9 ext/sys-plan9/s9-ffi.h format_C_files curses ext/curses/curses.c format_C_files csv ext/csv/csv.c format_C_files util util/rpp.c fi make_edoc() { echo -n "webdump/edoc.html ..." edoc -l scheme -w -P util/libhead -E util/libtail prog/edoc.scm.edoc \ | sed -e 's/@DESC@/Rendered EDOC Code/' \ -e 's/@BASE@/edoc.html<\/A>/' \ -e 's/@TITLE@/EDOC/' \ | sed -e '1,/^$/d' \ >webdump/_.html head -$(expr `wc -l webdump/_.html | awk '{print \$1}'` - 3) \ webdump/_.html > webdump/edoc.html rm -f webdump/_.html echo " done" } if [ $update_only = no -o $update_only = scm ]; then make_edoc format_scm_files "" s9.scm format_scm_files "" config.scm format_scm_files lib lib/*.scm format_scm_files contrib contrib/*.scm format_scm_files sys-unix ext/sys-unix/*.scm format_scm_files sys-plan9 ext/sys-plan9/*.scm format_scm_files curses ext/curses/*.scm format_scm_files csv ext/csv/*.scm format_scm_files prog prog/*.scm prog/*.scm.edoc format_scm_files util util/*.scm fi if [ $update_only = no -o $update_only = nah ]; then naah "" directory help naah "" directory freebsd-port naah contrib file S9Book naah contrib file S9Book-bw naah prog file adventure.intro naah util file blurb naah util file book naah util file dirhead naah util file dirtail naah util file libhead naah util file libtail naah util file mktoc.sed naah util file pagehead naah util file pagetail naah util file stress-tests.tgz naah util file categories.html fi if [ $update_only = no -o $update_only = man ]; then cc -o rpp util/rpp.c && ln -s util/rp_html rp_html format_man_pages -r s9.1 fi cleanup s9/util/make-docs000755 001751 001751 00000003730 13041750311 013565 0ustar00nmhnmh000000 000000 #!/bin/sh tmp=/tmp/make-doc.tmp.$$ tmp2=/tmp/make-doc.tmp2.$$ sigs=/tmp/make-doc.sigs.$$ prose=/tmp/make-doc.prose.$$ exms=/tmp/make-doc.exms.$$ cleanup() { rm -f $tmp $tmp2 $sigs $prose $exms } trap cleanup 1 2 3 format() { sed -e '1,/^;$/d' <$1 >$tmp sed -ne '1,/^;$/p' <$tmp | sed -e 's/^; //' -e '$d' >$sigs sed -e '1,/^;$/d' \ -e 's/; (load-from-library/; (load-from-library/' \ <$tmp >$tmp2 && mv -f $tmp2 $tmp sed -ne '1,/^;.*Example)*:/p' <$tmp | \ sed -e 's/^; //' -e 's/^;$//' -e '$d' >$prose sed -ne '/^;.*Example)*:/,/^$/p' <$tmp | sed -e '$d' | \ sed -e 's/^;$//' | \ sed -e 's/^.............//' >$exms sed -e '1s/^/S9 LIB /' -e '2,$s/^/ /' <$sigs echo cat $prose cat $exms } if [ ! -d help-new ]; then mkdir help-new mkdir help-new/sys-unix mkdir help-new/sys-plan9 mkdir help-new/curses mkdir help-new/csv fi for file in lib/*.scm contrib/*.scm; do if echo $file | grep -- '-test.scm' >/dev/null 2>&1; then continue fi format $file >help-new/$(basename $file .scm) echo $file done for ext in sys-unix sys-plan9 curses csv; do for file in ext/$ext/*.scm; do format $file >help-new/$ext/$(basename $file .scm) echo $file done done cd help-new rm -f csv/csv \ curses/curses \ fluid-let-sr \ format \ io-tools \ list-tools \ math-tools \ set-tools \ string-tools \ syntax-rules \ sys-plan9/plan9 \ sys-unix/unix \ unix-tools \ vector-tools mv -f amk runstar mv -f array make-array mv -f bitops bit0 mv -f bitwise-ops bitwise-and mv -f char-canvas make-canvas mv -f hof complement mv -f hash-table make-hash-table mv -f letcc letslashcc mv -f matcher define-matcher mv -f setters pushb mv -f rb-tree make-rbt mv -f records record mv -f regex re-comp mv -f simple-modules module mv -f s9sos define-class mv -f sys-unix/standard-error sys-unix/standard-error-port mv -f streams make-stream mv -f string-case string-upcase mv -f symbols r4rs-procedures mv -f threads thread-create mv -f time-ops time-add cleanup s9/util/libhead000644 001751 001751 00000000625 13201115050 013300 0ustar00nmhnmh000000 000000 @TITLE@ : S9fES : T3X.ORG
http://t3x.org/s9fes/@BASE@

@DESC@

s9/util/libtail000644 001751 001751 00000000105 11776510563 013350 0ustar00nmhnmh000000 000000

contact

s9/util/make-help-links000644 001751 001751 00000030304 13042075332 014701 0ustar00nmhnmh000000 000000 #!/bin/sh # Run this script in the S9 root to rebuild the help symlinks cd help || exit 1 cp="ln -sf" $cp amb amb-collector $cp amb amb-donep $cp amb amb-reset $cp assq assoc $cp assq assv $cp bit0 bitstar $cp bit0 bitstarc $cp bit0 bita $cp bit0 bitcstar $cp bit0 bitb $cp bit0 bitneq $cp bit0 bitplus $cp bit0 bitnplus $cp bit0 biteq $cp bit0 bitcb $cp bit0 bitplusc $cp bit0 bitca $cp bit0 bitcplus $cp bit0 bitnstar $cp bit0 bit1 $cp bit0 bitsl $cp bit0 bitsr $cp bitwise-and bitwise-1 $cp bitwise-and bitwise-2 $cp bitwise-and bitwise-and-c1 $cp bitwise-and bitwise-and-c2 $cp bitwise-and bitwise-and-not $cp bitwise-and bitwise-c1 $cp bitwise-and bitwise-c2 $cp bitwise-and bitwise-clear $cp bitwise-and bitwise-or $cp bitwise-and bitwise-or-c1 $cp bitwise-and bitwise-or-c2 $cp bitwise-and bitwise-or-not $cp bitwise-and bitwise-set $cp bitwise-and bitwise-shift-left $cp bitwise-and bitwise-shift-right $cp bitwise-and bitwise-xor $cp bitwise-and bitwise-xor-not $cp caar caaaar $cp caar caaadr $cp caar caaar $cp caar caadar $cp caar caaddr $cp caar caadr $cp caar cadaar $cp caar cadadr $cp caar cadar $cp caar caddar $cp caar cadddr $cp caar caddr $cp caar cadr $cp caar cdaaar $cp caar cdaadr $cp caar cdaar $cp caar cdadar $cp caar cdaddr $cp caar cdadr $cp caar cdar $cp caar cddaar $cp caar cddadr $cp caar cddar $cp caar cdddar $cp caar cddddr $cp caar cdddr $cp caar cddr $cp call-with-current-continuation callslashcc $cp call-with-input-file call-with-output-file $cp catch throw $cp char-alphabeticp char-lower-casep $cp char-alphabeticp char-numericp $cp char-alphabeticp char-upper-casep $cp char-alphabeticp char-whitespacep $cp char-cieqp char-cigep $cp char-cieqp char-cigtp $cp char-cieqp char-cilep $cp char-cieqp char-ciltp $cp char-to-integer integer-to-char $cp char-upcase char-downcase $cp chareqp chargep $cp chareqp chargtp $cp chareqp charlep $cp chareqp charltp $cp close-input-port close-output-port $cp combine combinestar $cp complement compose $cp complement const $cp complement curry $cp complement curryr $cp complement fork $cp current-input-port current-output-port (cd csv; $cp csv_read csv_write) (cd curses; $cp curs_addch curs_addstr) (cd curses; $cp curs_addch curs_beep) (cd curses; $cp curs_addch curs_flash) (cd curses; $cp curs_addch curs_move) (cd curses; $cp curs_addch curs_mvaddch) (cd curses; $cp curs_addch curs_mvaddstr) (cd curses; $cp curs_addch curs_refresh) (cd curses; $cp curs_addch curs_scroll) (cd curses; $cp curs_attroff curs_attron) (cd curses; $cp curs_attroff curs_attrset) (cd curses; $cp curs_attroff curs_standend) (cd curses; $cp curs_attroff curs_standout) (cd curses; $cp curs_cbreak curs_clearok) (cd curses; $cp curs_cbreak curs_echo) (cd curses; $cp curs_cbreak curs_get-magic-value) (cd curses; $cp curs_cbreak curs_idlok) (cd curses; $cp curs_cbreak curs_keypad) (cd curses; $cp curs_cbreak curs_nl) (cd curses; $cp curs_cbreak curs_nocbreak) (cd curses; $cp curs_cbreak curs_nodelay) (cd curses; $cp curs_cbreak curs_noecho) (cd curses; $cp curs_cbreak curs_nonl) (cd curses; $cp curs_cbreak curs_noraw) (cd curses; $cp curs_cbreak curs_raw) (cd curses; $cp curs_cbreak curs_resetty) (cd curses; $cp curs_cbreak curs_savetty) (cd curses; $cp curs_cbreak curs_scrollok) (cd curses; $cp curs_clear curs_clrtobot) (cd curses; $cp curs_clear curs_clrtoeol) (cd curses; $cp curs_color-set curs_has-colors) (cd curses; $cp curs_cursoff curs_curson) (cd curses; $cp curs_cursoff curs_mvcur) (cd curses; $cp curs_delch curs_deleteln) (cd curses; $cp curs_delch curs_insch) (cd curses; $cp curs_delch curs_insertln) (cd curses; $cp curs_delch curs_mvdelch) (cd curses; $cp curs_delch curs_mvinsch) (cd curses; $cp curs_endwin curs_initscr) (cd curses; $cp curs_flushinp curs_cols) (cd curses; $cp curs_flushinp curs_getch) (cd curses; $cp curs_flushinp curs_getyx) (cd curses; $cp curs_flushinp curs_inch) (cd curses; $cp curs_flushinp curs_lines) (cd curses; $cp curs_flushinp curs_mvgetch) (cd curses; $cp curs_flushinp curs_mvinch) (cd curses; $cp curs_flushinp curs_unctrl) (cd curses; $cp curs_flushinp curs_ungetch) $cp define-class call-next-method $cp define-class class-of $cp define-class classp $cp define-class define-generic $cp define-class define-method $cp define-class initialize $cp define-class instancep $cp define-class make-instance $cp define-class slot-ref $cp define-class slot-setb $cp define-matcher let-matcher $cp define-matcher make-matcher $cp draw-tree dt $cp duplicates dupp $cp duplicates dupq $cp duplicates dupv $cp eq ge $cp eq gt $cp eq le $cp eq lt $cp exact-to-inexact inexact-to-exact $cp exactp inexactp $cp exp log $cp exp sin $cp exp cos $cp exp tan $cp exp asin $cp exp acos $cp exp atan $cp exponent mantissa $cp floor ceiling $cp floor round $cp floor truncate $cp force delay $cp gcd lcm $cp get-prop put-prop $cp get-prop rem-prop $cp get-prop put-propb $cp get-prop rem-propb $cp help apropos $cp htmlify-char htmlify-string $cp id false $cp id true $cp input-portp output-portp $cp integer-to-binary-string binary-string-to-integer $cp integer-to-binary-string number-of-bits $cp iota iotastar $cp keyword-value accept-keywords $cp loutify-char loutify-string $cp macro-expand macro-expand-1 $cp make-array array $cp make-array arrayp $cp make-array array-dimensions $cp make-array array-map $cp make-array array-rank $cp make-array array-ref $cp make-array array-setb $cp make-array subarray $cp make-canvas canvas-draw $cp make-canvas canvas-draw-string $cp make-canvas canvas-dump $cp make-canvas canvas-plot $cp make-canvas canvas-plot-line $cp make-hash-table alist-to-hash-table $cp make-hash-table hash-table-length $cp make-hash-table hash-table-ref $cp make-hash-table hash-table-removeb $cp make-hash-table hash-table-setb $cp make-hash-table hash-table-to-alist $cp make-rbt rbt-find $cp make-rbt rbt-insert $cp make-rbt rbt-rebuild $cp make-rbt rbt-remove $cp make-stream append-streams $cp make-stream filter-stream $cp make-stream list-to-stream $cp make-stream map-stream $cp make-stream stream-any $cp make-stream stream-eosp $cp make-stream stream-extract $cp make-stream stream-id $cp make-stream stream-iota $cp make-stream stream-member $cp make-stream stream-next $cp make-stream stream-none $cp make-stream stream-to-list $cp make-stream stream-value $cp max min $cp memoize define-memoizing $cp memq member $cp memq memv $cp minus slash $cp module using $cp numberp integerp $cp numberp realp (cd sys-unix; $cp parse-optionsb display-usage) (cd sys-unix; $cp parse-optionsb opt-argp) (cd sys-unix; $cp parse-optionsb opt-char) (cd sys-unix; $cp parse-optionsb opt-type) (cd sys-unix; $cp parse-optionsb opt-val) (cd sys-unix; $cp parse-optionsb option) $cp permute permutestar $cp plus star $cp position posp $cp position posv $cp position posq $cp pretty-print pp $cp pretty-print pp-file $cp pretty-print pp-loop $cp pretty-print pp-string $cp prolog factb $cp prolog new-databaseb $cp prolog predicateb $cp prolog query $cp pushb decb $cp pushb incb $cp pushb popb $cp pushb set-varsb $cp pushb swapb $cp quasiquote unquote $cp quasiquote unquote-splicing $cp queue make-queue $cp queue queue-emptyp $cp queue queueb $cp queue unqueueb $cp queue unqueuestar $cp quotient modulo $cp quotient remainder $cp r4rs-procedures r4rs-syntax-objects $cp r4rs-procedures s9fes-syntax-objects $cp r4rs-procedures s9fes-procedures $cp r4rs-procedures s9fes-extension-procedures $cp r4rs-procedures s9fes-extension-symbols $cp random random-state $cp re-comp re-match $cp re-comp re-subst $cp record assert-record-type $cp record list-to-record $cp record record-copy $cp record record-equalp $cp record record-ref $cp record record-setb $cp record record-signature $cp record record-to-list $cp record record-type-matches $cp record recordp $cp remove remp $cp remove remq $cp remove remv $cp set-input-portb set-output-portb (cd sys-unix; $cp spawn-command spawn-command_fd) (cd sys-unix; $cp spawn-shell-command spawn-shell-command_fd) $cp split-url url-anchor $cp split-url url-args $cp split-url url-host $cp split-url url-path $cp split-url url-proto $cp split-url url-suffix (cd sys-unix; $cp standard-error-port call-with-stderr) (cd sys-unix; $cp standard-error-port with-output-to-stderr) $cp starstar starepsilonstar $cp starstar starextensionsstar $cp starstar starhost-systemstar $cp starstar starlibrary-pathstar $cp starstar starloadingstar $cp string-find string-ci-find $cp string-find string-ci-find-word $cp string-find string-find-word $cp string-find-last string-ci-find-last $cp string-find-last string-ci-find-last-word $cp string-find-last string-find-last-word $cp string-last-position string-ci-last-position $cp string-last-position string-ci-last-word-position $cp string-last-position string-last-word-position $cp string-locate string-ci-locate $cp string-map string-mapb $cp string-position string-ci-position $cp string-position string-ci-word-position $cp string-position string-word-position $cp string-prefixeqp string-prefix-cieqp $cp string-scan string-ci-scan $cp string-to-list list-to-string $cp string-upcase string-downcase $cp stringeqp string-cieqp $cp stringltp string-cigep $cp stringltp string-cigtp $cp stringltp string-cilep $cp stringltp string-ciltp $cp stringltp stringgep $cp stringltp stringgtp $cp stringltp stringlep (cd sys-unix; $cp sys_chmod sys_change_mode) (cd sys-unix; $cp sys_dup sys_dup2) (cd sys-unix; $cp sys_getgrnam sys_getgrgid) (cd sys-unix; $cp sys_getpgid sys_setpgid) (cd sys-unix; $cp sys_getpwnam sys_getpwuid) (cd sys-unix; $cp sys_getuid sys_getgid) (cd sys-unix; $cp sys_group-name sys_group-gid) (cd sys-unix; $cp sys_inet-listen sys_inet-accept) (cd sys-unix; $cp sys_kill sys_notify) (cd sys-unix; $cp sys_make-input-port sys_make-output-port) (cd sys-unix; $cp sys_open sys_close) (cd sys-unix; $cp sys_open sys_creat) (cd sys-unix; $cp sys_read sys_write) (cd sys-unix; $cp sys_setuid sys_setgid) (cd sys-unix; $cp sys_stat sys_lstat) (cd sys-unix; $cp sys_stat-name sys_lstat-atime) (cd sys-unix; $cp sys_stat-name sys_lstat-ctime) (cd sys-unix; $cp sys_stat-name sys_lstat-dev) (cd sys-unix; $cp sys_stat-name sys_lstat-gid) (cd sys-unix; $cp sys_stat-name sys_lstat-ino) (cd sys-unix; $cp sys_stat-name sys_lstat-mode) (cd sys-unix; $cp sys_stat-name sys_lstat-mtime) (cd sys-unix; $cp sys_stat-name sys_lstat-name) (cd sys-unix; $cp sys_stat-name sys_lstat-nlink) (cd sys-unix; $cp sys_stat-name sys_lstat-size) (cd sys-unix; $cp sys_stat-name sys_lstat-uid) (cd sys-unix; $cp sys_stat-name sys_stat-atime) (cd sys-unix; $cp sys_stat-name sys_stat-ctime) (cd sys-unix; $cp sys_stat-name sys_stat-dev) (cd sys-unix; $cp sys_stat-name sys_stat-gid) (cd sys-unix; $cp sys_stat-name sys_stat-ino) (cd sys-unix; $cp sys_stat-name sys_stat-mode) (cd sys-unix; $cp sys_stat-name sys_stat-mtime) (cd sys-unix; $cp sys_stat-name sys_stat-nlink) (cd sys-unix; $cp sys_stat-name sys_stat-size) (cd sys-unix; $cp sys_stat-name sys_stat-uid) (cd sys-unix; $cp sys_stat-regularp sys_lstat-block-devp) (cd sys-unix; $cp sys_stat-regularp sys_lstat-char-devp) (cd sys-unix; $cp sys_stat-regularp sys_lstat-directoryp) (cd sys-unix; $cp sys_stat-regularp sys_lstat-pipep) (cd sys-unix; $cp sys_stat-regularp sys_lstat-regularp) (cd sys-unix; $cp sys_stat-regularp sys_lstat-socketp) (cd sys-unix; $cp sys_stat-regularp sys_lstat-symlinkp) (cd sys-unix; $cp sys_stat-regularp sys_stat-block-devp) (cd sys-unix; $cp sys_stat-regularp sys_stat-char-devp) (cd sys-unix; $cp sys_stat-regularp sys_stat-directoryp) (cd sys-unix; $cp sys_stat-regularp sys_stat-pipep) (cd sys-unix; $cp sys_stat-regularp sys_stat-socketp) (cd sys-unix; $cp sys_user-name sys_user-gecos) (cd sys-unix; $cp sys_user-name sys_user-gid) (cd sys-unix; $cp sys_user-name sys_user-home) (cd sys-unix; $cp sys_user-name sys_user-shell) (cd sys-unix; $cp sys_user-name sys_user-uid) (cd sys-unix; $cp sys_usleep sys_sleep) (cd sys-unix; $cp sys_wait sys_waitpid) $cp t-sort t-sort-net $cp tagbody go $cp thread-create thread-exit $cp thread-create thread-start $cp thread-create thread-yield $cp time-add time-subtract $cp time-add time-difference $cp time-add time-beforep $cp time-add time-afterp (cd sys-unix; $cp time timestar) $cp type-case type-of $cp vector-to-list list-to-vector $cp vector-map vector-mapb $cp when unless $cp while until $cp with-input-from-file with-output-to-file $cp write-to-string display-to-string $cp zerop evenp $cp zerop negativep $cp zerop oddp $cp zerop positivep s9/util/stress-tests.tgz000644 001751 001751 00000007466 12034032644 015222 0ustar00nmhnmh000000 000000 ‹¤5pPíÛ–Û¶1¯ÖWà¬"¹QJÜIo.§íi›ô¤~q€+Q»ÊJ¤LRÎ:_ß Á‹ÈMÎzã$_HƒÁÌ`fpWQæIQ¬Ë¤(‹¿~öq -%'Õ’úÏ¥\k­˜Tœ”SÍ>#ò#ñÓ‚sQÆ9°’ïFñ¦ò­õów…ßþñáð1ê}(!.¶?•ZÊ.Î5í¯„þŒƒ™.üÉÛÿ%yíþù–Tv@Œ,^’¿ oö‡‚ü—|—Ž_áš4€<øû}ú>»OHy·/ÈnHÈ.ÏŽð™5r ÙîódSfùòÓ¾¼[¼„Bw¤ks‹E²¹ËÈ:%Wÿþ‡¡W¼& \]“rLÈ—-"²Þµ‹ßn þ—ÅæØ¢rØCî/ bð{TiŸÞzt&¨Xü›<‰ï7¿M廧$'ü—û,51„—eûÛT@–k’º2°h’+î1íp¸O .uƒOYÇ”ÿkQÿ)"¢ÿ 5ûÿsÀ5ÙÀX£LÈÁtdØþØ_7å9OÀÿ·ÉnŸ&àŠY“¹ë;ÿË?Ü÷Óå&K·€ñ5y ‡•ù,€F¾ê83¢&ˆMú?ežÿ+ô=÷ÿϵÿ¿O`®vÈpTmlÀó}Ì¿Îõ«ÞûaÕÎöùÅ‹/Ȳª}Ÿ çÞ’+ßl€Û»ý÷‡cšÞó¢<ÿôðáç+,ðâE+Bʽ¯®z¾­´4neé;ïªdcò²oUžÔÅ? /¿®ý‡§ŒOkcSë?BÑÆÿ%Cÿ˜œýÿ9 vrÓö0|ŽÉqôºïNI]í_È Ž¬k'®r¨ÉÁ"íÄ%q›ö«ì”pìÌNå`¦h2=.!hÜTc}ý‹^¡ÙéÀ¥r&B8ñ·ûÛ}YTóŒvÛ6Anƒaì…˜|C6ˆþ¢ª;w/ˆÿ fJdctCÝfa3) z±É²'GMà*¸Œ´EêN0ˆÏóüARIQ.:bQ$ ¢HÂp›‰( Y Cp=¦…Ž¸’ø1qtDÆ¥¢BpͨV"€Á‡æR¨H«0 ¡, ©RQÀÓð8 eHC%BÈ ”\K†,¤4J*¨] ΕT„"ˆÔ°`â²`¶…j%¸" *&%[¤®Gi)C Ñ& ýÖûÄ0¸Ü÷ÄuŒÇ€axñ_ìd0Çÿç€:ãûdÝ, EBœ‰ô–yìœÐ%£—}MÚ‰¾™’uSí”°šä˜p Å;o<·¬Y_`Âîʧ½¬Ž`®·lϛΠ²h7¯•ÂøóðT£ÐÞȵÆ=Æ'oÜâŽâŸ&ñ=áp.|˜8â×:«ºÀ‡Õjª¤›e¦­Áôr·?”I¾Ž‹ ¨'}H7dHχ÷ðµÍ‘cr꨾Òì7…7qÞ—©Öæ 1Ýcª®j°!G°ë^9O`ö3ŒÜ¨2í-$ïÎ1JÚu*GS“0$ ÂŒš(7Ã!xÐê›™A<˜û¦&kP”šaTs—¼¥ãüúfÀ­ÚdNuž­k˜àc­6ÍE£{´Å¾êŸÌÔâ!þª+§Wξbøc=¥×4Rë=<ã>Õþá«ñ}Ï~™ít!×±8¯ú”–IIëUZ]™ðòXS1b¶3yÝO*A{DZÚ;ýÊ_Y"MoÙäÁÞP:Qs‰#Å~)>FŠÏóôO/Ú=qã&÷ÆÿÂŒÿ5ŸÇÿÏÍø?-“Û$_£ âÝ9Γd2:pˆa"^wõt“Iÿƒþ…–v«V§h9጖30ð¿€é‹E*’ø ùšK†T‘’RÈ( àRɵˆð®~u­#Í”U*¤T Î#&À³4Ò:¤,‚ÞOIÍ© 9g,¬ EL#UŠ·= -ª§yÑA€çL!*„2ŒXu5 ´X¨ 1–PÀŠdxàÐTÄ5ú’q¨.à‚Ó@jÍ"2`(„ hÀ?¥L1ÃKHÃH±0P¡ÒÐTŠ#À©’\‚Dè¨ RƒÔ!PÉ©6Gk ¨$CÍF"ÆRÂüœRP¹¤È,ÈΙ AÉ,’V§âÌ,vp ˆ""¥)h0Œ¢"b$"JrÐ#Ó A9)4±ñ$åðj‡*4´¨EŒ¤À0¨j¶B¨–Cº„H Ú1ä ClSÀ׸¤!dz»$K-% Ægœ)F(øS`  „´6ÔJ;™ÀBò ’TF*@sÃaZjÐR‹˜ 1´.0hAPP€&Q˜Ìþ/ ÷!ð ÍÁ 0H¼€•‚°€- (´h¤³â¡†¶Ç–Ä­BPáÛíTJàëì$´œå{â· —nÉ?eSý?XGýû/AÀÍýO9ßÿz¸&ö·ð’Þ¡ ßdÇS¼1‡n›µ‰Ý>/Ê5Þ͸À^Erw˜p¤pW\0-¿ÄùÆ* ·ï\~*:%aòT&­ªÜ•°6ÕnîqÙ'h6 ‹¥?ì-Ý ¦è^6¹†NÌ|°¿ØifÔ©ײ´î§»£§€Q )Ãgþ”äÇsi®æëqV·äãmÖºØ%<\ƒu×}Ž›çžÛe{fº}È (ô2>ªá‹•]‹yL ßr¦ÙªÁpô˜õSׂµñšJ¦–'Úêîï𓼛®’+wgòª·Yn°Â´Äÿ$=Ý C0üû6O[ÇÔþ¿lú £ßêþç|ÿçYàÜ¿$Оó¢Ýßo““Ù¨XØðïóÖjº™´Û Œª`íJõ"[ÐêÑÐÒì£ÞµéSíÚ´Aw½g»sneU²Z@.mšål¬Ë,O»{€†[R® Vg-Á!Ùðj‘ðƧ‹¦†~>—ñóâoS=aS÷¿!Ôþ“NôIÅìÿÏÿÿÂý”îOtÆÿ‡¸,“tmúÃèÝäAj3hð¢ÜÐD,«º.”Àú*3ûx€saÔÙE¤ý½± qhù¸(ôоʄz¸qíÁ…5«Ä‘À6Ú¼ÁŸd‚…a3úë´ü:c@ëåó¸o†f˜a†f˜a†f˜a†f˜a†f˜a†f˜a†f˜a†f˜áÿ¯Æ0éxs9/util/systest.scm000644 001751 001751 00000041701 12537051773 014235 0ustar00nmhnmh000000 000000 ; Scheme 9 from Empty Space ; Unix Extension Test Suite ; By Nils M Holm, 2010,2012 ; NOTE: SOCKET-TEST will fail if this test is run ; multiple times in quick succession. (load-from-library "mergesort.scm") (load-from-library "displaystar.scm") (load-from-library "read-line.scm") (load-from-library "bitops.scm") ; ----- Prelude -------------------------------------------------------------- (define *SANDBOX* "systest-sandbox") (define *Errors* 0) (define fd #f) (define fd0 #f) (sys:catch-errors #t) (if (zero? (sys:getuid)) (error "friends don't let friends test as root!")) (sys:umask #o22) (if (not (sys:mkdir *SANDBOX*)) (error "could not create systest sandbox" (sys:strerror (sys:errno)))) (sys:mkdir *SANDBOX*) ; errors caught? (if (not (sys:chdir *SANDBOX*)) (error "could not chdir to test sandbox!" (sys:strerror (sys:errno)))) (define (test2 form passed) ; (write form) (display " => ") (write passed) (newline) (if (not passed) (begin (set! *Errors* (+ 1 *Errors*)) (display "FAILED: ") (write form) (display* #\newline "REASON: " (sys:strerror (sys:errno)) #\newline)))) (define-syntax (test form) `(begin (sys:errno) (test2 ',form ,form))) (define-syntax (test/fd form) `(begin (sys:errno) (test2 ',form (let ((x ,form)) (set! fd x) x)))) (define-syntax (test/close form) `(begin (sys:errno) (test2 ',form (let ((fd ,form)) (sys:close fd) fd)))) (define (fail2 form passed) (if passed (begin (set! *Errors* (+ 1 *Errors*)) (display "FAILED: ") (write form) (display* #\newline "REASON: succeeded, but should have failed" #\newline)))) (define-syntax (fail form) `(begin (sys:errno) (fail2 ',form ,form))) (define (stat-umode file) (bit* #o777 (sys:stat-mode file))) ; ----- Directory creation and access ---------------------------------------- (fail (sys:chdir *SANDBOX*)) (test (sys:mkdir "testdir")) (fail (sys:mkdir "testdir")) (test (not (sys:stat-block-dev? "testdir"))) (test (not (sys:stat-char-dev? "testdir"))) (test (sys:stat-directory? "testdir")) (test (not (sys:stat-pipe? "testdir"))) (test (not (sys:stat-regular? "testdir"))) (test (not (sys:stat-socket? "testdir"))) (test (not (sys:lstat-symlink? "testdir"))) (test (sys:chdir "testdir")) (fail (sys:chdir "testdir")) (test (sys:chdir "..")) (test (sys:rmdir "testdir")) (fail (sys:rmdir "testdir")) (test (sys:getcwd)) (test (sys:chdir (sys:getcwd))) ; ----- Stat ----------------------------------------------------------------- (test (let ((s (sys:stat "."))) (not (memq #f (map (lambda (x) (assq x s)) '(name size uid gid mode ctime atime mtime dev ino nlink)))))) (test/close (sys:creat "testfile")) (test/close (sys:creat "testfile")) (test (not (sys:stat-block-dev? "testfile"))) (test (not (sys:stat-char-dev? "testfile"))) (test (not (sys:stat-directory? "testfile"))) (test (not (sys:stat-pipe? "testfile"))) (test (sys:stat-regular? "testfile")) (test (not (sys:stat-socket? "testfile"))) (test (not (sys:lstat-symlink? "testfile"))) (test (sys:getuid)) (test (sys:getgid)) (test (equal? (sys:stat-name "testfile") "testfile")) (test (equal? (sys:stat-size "testfile") 0)) (test (equal? (sys:stat-uid "testfile") (sys:getuid))) (test (equal? (sys:stat-gid "testfile") (sys:getgid))) (test/close (sys:creat "testfile")) (test (equal? (sys:stat-ctime "testfile") (sys:stat-mtime "testfile"))) (test (equal? (sys:stat-nlink "testfile") 1)) (test (sys:link "testfile" "testlink")) (test (equal? (sys:stat-nlink "testfile") 2)) (test (equal? (sys:stat-name "testlink") "testlink")) (test (equal? (sys:stat-size "testlink") 0)) (test (equal? (sys:stat-uid "testlink") (sys:getuid))) (test (equal? (sys:stat-gid "testlink") (sys:getgid))) (test (equal? (sys:stat-ctime "testlink") (sys:stat-mtime "testlink"))) (test (equal? (sys:stat-nlink "testlink") 2)) (test (sys:unlink "testfile")) (test (equal? (sys:stat-nlink "testlink") 1)) (test (sys:unlink "testlink")) (fail (sys:stat "testlink")) ; ----- File creation and access --------------------------------------------- (fail (sys:open "testfile" sys:read-only)) (test/close (sys:creat "testfile")) (test/fd (sys:open "testfile" sys:read-only)) (test (sys:close fd)) (fail (sys:close fd)) (test (sys:unlink "testfile")) (test/close (sys:creat "testfile" #o400)) (fail (sys:open "testfile" sys:write-only)) (test (sys:unlink "testfile")) (test/close (sys:creat "testfile" #o200)) (fail (sys:open "testfile" sys:read-only)) (test (sys:unlink "testfile")) (test/close (sys:creat "testfile" #o600)) (test/fd (sys:open "testfile" sys:write-only)) (fail (sys:read fd 1024)) (test (sys:write fd "hello, world!")) (test (= (sys:stat-size "testfile") 13)) (test (sys:close fd)) (test/fd (sys:open "testfile" sys:read-only)) (fail (sys:write fd "hello, world!")) (test (equal? "hello, world!" (sys:read fd 1024))) (test (sys:close fd)) (test/fd (sys:open "testfile" sys:read-only)) (test (equal? "hello" (sys:read fd 5))) (test/fd (sys:open "testfile" sys:read+write)) (test (sys:write fd "HELLO, world!")) (test (sys:lseek fd 0 sys:seek-set)) (test (equal? "HELLO, world!" (sys:read fd 1024))) (test (sys:lseek fd -1 sys:seek-end)) (test (sys:write fd "...")) (test (sys:lseek fd 0 sys:seek-set)) (test (equal? "HELLO, world..." (sys:read fd 1024))) (test (sys:lseek fd -15 sys:seek-cur)) (test (sys:write fd "hello")) (test (sys:lseek fd 0 sys:seek-set)) (test (equal? "hello, world..." (sys:read fd 1024))) (set! fd0 fd) (test/fd (sys:dup fd0)) (test (sys:lseek fd 0 sys:seek-set)) (test (sys:write fd "FOO")) (test (sys:lseek fd0 0 sys:seek-set)) (test (equal? "FOO" (sys:read fd0 3))) (test (sys:close fd0)) (set! fd0 fd) (test/fd (sys:dup2 fd0 (sys:open "testfile" sys:read-only))) (test (sys:lseek fd 0 sys:seek-set)) (test (sys:write fd "BAR")) (test (sys:lseek fd0 0 sys:seek-set)) (test (equal? "BAR" (sys:read fd0 3))) (test (sys:close fd)) (test (sys:close fd0)) (test (sys:unlink "testfile")) ; ----- File mode ------------------------------------------------------------ (test/close (sys:creat "modefile")) (test (= (stat-umode "modefile") #o644)) (test (sys:unlink "modefile")) (test/fd (sys:creat "modefile" #o600)) (test (= (stat-umode "modefile") #o600)) (test (sys:umask #o000)) (test (sys:unlink "modefile")) (test (sys:creat "modefile" #o731)) (test (= (stat-umode "modefile") #o731)) (test (sys:umask #o007)) (test (sys:unlink "modefile")) (test (sys:creat "modefile" #o731)) (test (= (stat-umode "modefile") #o730)) (test (sys:umask #o070)) (test (sys:unlink "modefile")) (test (sys:creat "modefile" #o731)) (test (= (stat-umode "modefile") #o701)) (test (sys:umask #o700)) (test (sys:unlink "modefile")) (test (sys:creat "modefile" #o731)) (test (= (stat-umode "modefile") #o031)) (test (sys:umask #o022)) (test (sys:chmod "modefile" #o644)) (test (= (stat-umode "modefile") #o644)) (test (sys:chmod "modefile" "644")) (test (= (stat-umode "modefile") #o644)) (test (sys:chmod "modefile" "u=rw,g=r,o=r")) (test (= (stat-umode "modefile") #o644)) (test (sys:chmod "modefile" "a-rwx,u+rw,go+r")) (test (= (stat-umode "modefile") #o644)) (test (sys:chmod "modefile" "a=rwx,u-x,go-wx")) (test (= (stat-umode "modefile") #o644)) (test (sys:chmod "modefile" "a-w")) (test (= (stat-umode "modefile") #o444)) (test (sys:chmod "modefile" "g+x")) (test (= (stat-umode "modefile") #o454)) (test (sys:chmod "modefile" "u+w")) (test (= (stat-umode "modefile") #o654)) (test (sys:chmod "modefile" #o000)) (test (sys:access "modefile" sys:access-f-ok)) (fail (sys:access "modefile" sys:access-r-ok)) (fail (sys:access "modefile" sys:access-w-ok)) (fail (sys:access "modefile" sys:access-x-ok)) (test (sys:chmod "modefile" #o100)) (fail (sys:access "modefile" sys:access-r-ok)) (fail (sys:access "modefile" sys:access-w-ok)) (test (sys:access "modefile" sys:access-x-ok)) (test (sys:chmod "modefile" #o200)) (fail (sys:access "modefile" sys:access-r-ok)) (test (sys:access "modefile" sys:access-w-ok)) (fail (sys:access "modefile" sys:access-x-ok)) (test (sys:chmod "modefile" #o400)) (test (sys:access "modefile" sys:access-r-ok)) (fail (sys:access "modefile" sys:access-w-ok)) (fail (sys:access "modefile" sys:access-x-ok)) (test (sys:unlink "modefile")) ; ----- File owner ----------------------------------------------------------- (test/close (sys:creat "userfile")) (test (sys:chown "userfile" #f #f)) (test (= (sys:stat-uid "userfile") (sys:getuid))) (test (= (sys:stat-gid "userfile") (sys:getgid))) (test (sys:chown "userfile" (sys:getuid) #f)) (test (sys:chown "userfile" #f (sys:getgid))) (test (sys:chown "userfile" (sys:getuid) (sys:getgid))) (test (= (sys:stat-uid "userfile") (sys:getuid))) (test (= (sys:stat-gid "userfile") (sys:getgid))) (fail (sys:chown "userfile" 0 #f)) (fail (sys:chown "userfile" 0 0)) (test (sys:unlink "userfile")) ; ----- Directory Entries ---------------------------------------------------- (test/close (sys:creat "name")) (test (sys:rename "name" "other-name")) (fail (sys:rename "name" "other-name")) (test/close (sys:creat "name")) (test (sys:rename "other-name" "name")) (test (= 1 (sys:stat-nlink "name"))) (test (sys:link "name" "alias")) (test (= 2 (sys:stat-nlink "name"))) (test (= 2 (sys:stat-nlink "alias"))) (test (sys:unlink "alias")) (test (= 1 (sys:stat-nlink "name"))) (test (sys:link "name" "alias")) (test (= 2 (sys:stat-nlink "name"))) (test (sys:symlink "name" "reference")) (test (= 2 (sys:stat-nlink "name"))) (test (sys:lstat-symlink? "reference")) (test (= 0 (sys:stat-size "reference"))) (test (= 4 (sys:lstat-size "reference"))) (test (= 2 (sys:stat-nlink "reference"))) (test (= 1 (sys:lstat-nlink "reference"))) (test (equal? "name" (sys:readlink "reference"))) (fail (sys:readlink "name")) (test (sys:utimes "reference")) (test (sys:unlink "reference")) (test (sys:unlink "alias")) (test (sys:unlink "name")) (test (sys:creat "foo")) (test (sys:creat "bar")) (test (sys:creat "baz")) (test (equal? '("bar" "baz" "foo") (mergesort string Packages by category : S9fES
http://t3x.org/s9fes/CATEGORIES.html

Packages by Category

Interactive programs | Visualization | Embedded languages | Logic programming | Data structures | User interface | Networking | Control | Binding constructs and setters | String operations | Input/Output | System functions | Time functions | Set operations | List operations | Sorting | Graph operations | Vector operations | Math operations | Modules | Miscellanea | Stand-alone programs | Test suites

Interactive programs

help.scm
prolog.scm @

Visualization

char-canvas.scm
char-plot.scm
draw-tree.scm
pretty-print.scm
runtime-stats.scm @

Embedded languages

amb.scm
amk.scm
matcher.scm @
programp.scm
prolog.scm
s9sos.scm
syntax-rules.scm

Logic programming

amb.scm @
amk.scm @
prolog.scm @

Data structures

array.scm
define-structure.scm
hash-table.scm
queue.scm
records.scm
rb-tree.scm
s9sos.scm @
streams.scm

User interface

curses.scm
get-line.scm
keyword-value.scm
parse-optionsb.scm @

Networking

inet-server.scm
split-url.scm
url-decode.scm

Control

and-letstar.scm
catch.scm
cond-expand.scm
letcc.scm
matcher.scm
memoize.scm
string-map.scm @
tagbody.scm
threads.scm
tree-map.scm @
type-case.scm
vector-map.scm @
when.scm
while.scm

Binding constructs and setters

and-letstar.scm @
fluid-let-sr.scm
fluid-let.scm
letrecstar.scm
setters.scm

String operations

basename.scm @
dirname.scm @
format-time.scm @
format.scm @
htmlify-char.scm
integer-to-binary-string.scm @
mode-to-string.scm @
loutify-char.scm
read-from-string.scm @
regex.scm
split-url.scm @
string-case.scm
string-digest.scm
string-expand.scm
string-find-last.scm
string-find.scm
string-last-position.scm
string-locate.scm
string-map.scm
string-parse.scm
string-position.scm
string-prefixeqp.scm
string-reverse.scm
string-scan.scm
string-split.scm
string-tools.scm
string-translate.scm
string-unsplit.scm
write-to-string.scm @

Input/Output

append-to-output-file.scm
displaystar.scm
flush-output-port.scm
format.scm
get-line.scm @
read-file.scm
read-from-string.scm
read-line.scm
standard-error.scm
write-to-string.scm

System functions

basename.scm
dirname.scm
find-help-path.scm
find-help.scm
format-time.scm
leap-yearp.scm
mode-to-string.scm
name-to-file-name.scm
parse-optionsb.scm
search-path.scm
spawn-command.scm
spawn-shell-command.scm
time-to-unix-time.scm
unix-time-to-time.scm

Time functions

format-time.scm @
leap-yearp.scm @
proper-timep.scm
runtime-stats.scm
time-ops.scm
time-to-unix-time.scm @
time.scm
unix-time-to-time.scm @

Set operations

adjoin.scm
combine.scm
exists.scm
for-all.scm
intersection.scm
permute.scm
set-difference.scm
subsetp.scm
union.scm

List operations

appendb.scm
assp.scm
collect.scm
duplicates.scm
filter.scm
flatten.scm
get-prop.scm
group.scm
iota.scm
list-to-set.scm
list-copy.scm
listq.scm
memp.scm
merge.scm
mergesort.scm
partition.scm
position.scm
setters.scm @
quicksort.scm
random-sort.scm
remove.scm
replace.scm
split.scm
sublist.scm
substitute.scm
take.scm
unsort.scm

Sorting

mergesort.scm @
quicksort.scm @
random-sort.scm @
sort.scm
unsort.scm @

Graph operations

count.scm
depth.scm
equal-cip.scm
t-sort.scm
tree-copy.scm
tree-equalp.scm
tree-map.scm

Vector operations

subvector.scm
vector-map.scm

Math operations

bitops.scm
bitwise-ops.scm
cdf.scm
erf.scm
factor.scm
factorial.scm
hyper.scm
integer-sqrt.scm
iota.scm @
mean.scm
median.scm
mode.scm
make-partitions.scm
ndf.scm
quartile.scm
random.scm
range.scm
sieve.scm
stddev.scm
sum.scm
t-sort.scm @
transpose.scm
variance.scm

Modules

package.scm
simple-modules.scm

Miscellanea

explode.scm
id.scm
implode.scm
symbols.scm

Stand-alone programs

advgen.scm
bottles.scm
c2html.scm
cols.scm
dupes.scm
edoc.scm.edoc
htmlify.scm
s9help.scm
s9hts.scm
s9resolve.scm
scm2html.scm
scmpp.scm
soccat.scm
zebra.scm

Test suites

libtest.scm
realtest.scm
srtest.scm
systest.scm
test.scm

contact

s9/util/make-cats.scm000644 001751 001751 00000004467 11427217363 014370 0ustar00nmhnmh000000 000000 ; Create the CATEGORIES.html file for the webdump. (load-from-library "read-line.scm") (load-from-library "string-split.scm") (load-from-library "displaystar.scm") (load-from-library "hash-table.scm") (load-from-library "regex.scm") (define *descriptions* (make-hash-table)) (define (fetch-descriptions) (with-input-from-file "util/descriptions" (lambda () (let loop () (let ((entry (read-line))) (if (not (eof-object? entry)) (let* ((s* (string-split #\| entry)) (key (car s*)) (val (if (string=? "-" (cadddr s*)) (caddr s*) (cadddr s*)))) (hash-table-set! *descriptions* key val) (loop)))))))) (define (get-description name) (cond ((hash-table-ref *descriptions* name) => car) (else "(no description)"))) (define (make-categories) (let ((entry (re-comp "
\\(.*\\)
"))) (let loop () (let ((line (read-line))) (cond ((eof-object? line)) ((re-match entry line) => (lambda (match) (let* ((file (apply substring line (cadr match))) (k (string-length file)) (ref (char=? #\@ (string-ref file (- k 1)))) (file (if ref (substring file 0 (- k 2)) file))) (display* "
" (if ref "" "") "" file ": " (get-description file) (if ref "" "") "
" #\newline) (loop)))) (else (display* line #\newline) (loop))))))) (if (file-exists? "CATEGORIES.html") (delete-file "CATEGORIES.html")) (fetch-descriptions) (with-input-from-file "util/categories.html" (lambda () (with-output-to-file "CATEGORIES.html" make-categories))) s9/util/realtest.scm000644 001751 001751 00000131740 12540610767 014343 0ustar00nmhnmh000000 000000 ; Scheme 9 from Empty Space ; Real Number Test Suite ; By Nils M Holm, 2008, 2009 (define testfile "__testfile__") (if (file-exists? testfile) (error (string-append "Please delete the file \"" testfile "\" before running this test."))) (define Errors 0) (define (void) (if #f #f)) (define (seq) (let ((n 1)) (lambda () (let ((x n)) (set! n (+ 1 n)) x)))) (define (fail expr result expected) (display "test failed: ") (write expr) (newline) (display "got result: ") (write result) (newline) (display "expected: ") (write expected) (newline) (set! Errors (+ 1 Errors))) (define (test3 expr result expected) ; (write expr) (display " => ") (write result) (newline) (if (not (equal? result expected)) (fail expr result expected))) (define-syntax (test form result) `(test3 ',form ,form ,result)) ; --- syntax --- (test 0.0 0.0) (test -0.0 -0.0) (test 1.0 1.0) (test -1.0 -1.0) (test 12345.0 12345.0) (test -12345.0 -12345.0) (test 1.2345 1.2345) (test -1.2345 -1.2345) (test 0.12345 0.12345) (test -0.12345 -0.12345) (test -0.00012345 -0.00012345) (test 0.1 0.1) (test 0.01 0.01) (test 0.001 0.001) (test 0.0000000000001 0.0000000000001) (test 1e0 1.0) (test 1e-0 1.0) (test 1e1 10.0) (test 1e2 100.0) (test 1e5 100000.0) (test 1e10 10000000000.0) (test 1e-1 0.1) (test 1e-2 0.01) (test 1e-5 0.00001) (test 1e-10 0.0000000001) (test 123.456e0 123.456) (test 123.456e1 1234.56) (test 123.456e2 12345.6) (test 123.456e3 123456.0) (test 123.456e4 1234560.0) (test 123.456e5 12345600.0) (test 123.456e10 1234560000000.0) (test -123.456e0 -123.456) (test -123.456e1 -1234.56) (test -123.456e2 -12345.6) (test -123.456e3 -123456.0) (test -123.456e4 -1234560.0) (test -123.456e5 -12345600.0) (test -123.456e10 -1234560000000.0) (test 123.456e-1 12.3456) (test 123.456e-2 1.23456) (test 123.456e-3 0.123456) (test 123.456e-4 0.0123456) (test 123.456e-5 0.00123456) (test 123.456e-10 0.0000000123456) (test -123.456e-1 -12.3456) (test -123.456e-2 -1.23456) (test -123.456e-3 -0.123456) (test -123.456e-4 -0.0123456) (test -123.456e-5 -0.00123456) (test -123.456e-10 -0.0000000123456) (test +123.45e+678 123.45e678) (test -123.45e+678 -123.45e678) (test +123.45e-678 123.45e-678) (test -123.45e-678 -123.45e-678) (test 1. 1.0) (test .1 0.1) (test 1.e1 10.0) (test .1e1 1.0) (test 1000e0 1e3) (test 100e1 1e3) (test 10e2 1e3) (test 1e3 1e3) (test .1e4 1e3) (test .01e5 1e3) (test .001e6 1e3) (test 12345678.901D10 1.2345678901e+17) (test 12345678.901E10 1.2345678901e+17) (test 12345678.901F10 1.2345678901e+17) (test 12345678.901L10 1.2345678901e+17) (test 12345678.901S10 1.2345678901e+17) ; --- type predicates --- (test (boolean? #f) #t) (test (boolean? #\c) #f) (test (boolean? 1) #f) (test (boolean? 0.1) #f) (test (boolean? '(pair)) #f) (test (boolean? (lambda () #f)) #f) (test (boolean? "string") #f) (test (boolean? 'symbol) #f) (test (boolean? '#(vector)) #f) (test (boolean? (current-input-port)) #f) (test (boolean? (current-output-port)) #f) (test (char? #f) #f) (test (char? #\c) #t) (test (char? 1) #f) (test (char? 0.1) #f) (test (char? '(pair)) #f) (test (char? (lambda () #f)) #f) (test (char? "string") #f) (test (char? 'symbol) #f) (test (char? '#(vector)) #f) (test (char? (current-input-port)) #f) (test (char? (current-output-port)) #f) (test (input-port? #f) #f) (test (input-port? #\c) #f) (test (input-port? 1) #f) (test (input-port? 0.1) #f) (test (input-port? '(pair)) #f) (test (input-port? (lambda () #f)) #f) (test (input-port? "string") #f) (test (input-port? 'symbol) #f) (test (input-port? '#(vector)) #f) (test (input-port? (current-input-port)) #t) (test (input-port? (current-output-port)) #f) (test (integer? #f) #f) (test (integer? #\c) #f) (test (integer? 1) #t) (test (integer? 1.0) #t) (test (integer? 0.1) #f) (test (integer? '(pair)) #f) (test (integer? (lambda () #f)) #f) (test (integer? "string") #f) (test (integer? 'symbol) #f) (test (integer? '#(vector)) #f) (test (integer? (current-input-port)) #f) (test (integer? (current-output-port)) #f) (test (number? #f) #f) (test (number? #\c) #f) (test (number? 1) #t) (test (number? 0.1) #t) (test (number? '(pair)) #f) (test (number? (lambda () #f)) #f) (test (number? "string") #f) (test (number? 'symbol) #f) (test (number? '#(vector)) #f) (test (number? (current-input-port)) #f) (test (number? (current-output-port)) #f) (test (output-port? #f) #f) (test (output-port? #\c) #f) (test (output-port? 1) #f) (test (output-port? 0.1) #f) (test (output-port? '(pair)) #f) (test (output-port? (lambda () #f)) #f) (test (output-port? "string") #f) (test (output-port? 'symbol) #f) (test (output-port? '#(vector)) #f) (test (output-port? (current-input-port)) #f) (test (output-port? (current-output-port)) #t) (test (pair? #f) #f) (test (pair? #\c) #f) (test (pair? 1) #f) (test (pair? 0.1) #f) (test (pair? '(pair)) #t) (test (pair? (lambda () #f)) #f) (test (pair? "string") #f) (test (pair? 'symbol) #f) (test (pair? '#(vector)) #f) (test (pair? (current-input-port)) #f) (test (pair? (current-output-port)) #f) (test (port? #f) #f) (test (port? #\c) #f) (test (port? 1) #f) (test (port? 0.1) #f) (test (port? '(pair)) #f) (test (port? (lambda () #f)) #f) (test (port? "string") #f) (test (port? 'symbol) #f) (test (port? '#(vector)) #f) (test (port? (current-input-port)) #t) (test (port? (current-output-port)) #t) (test (procedure? #f) #f) (test (procedure? #\c) #f) (test (procedure? 1) #f) (test (procedure? 0.1) #f) (test (procedure? '(procedure)) #f) (test (procedure? (lambda () #f)) #t) (test (procedure? "string") #f) (test (procedure? 'symbol) #f) (test (procedure? '#(vector)) #f) (test (procedure? (current-input-port)) #f) (test (procedure? (current-output-port)) #f) (test (string? #f) #f) (test (string? #\c) #f) (test (string? 1) #f) (test (string? 0.1) #f) (test (string? '(pair)) #f) (test (string? (lambda () #f)) #f) (test (string? "string") #t) (test (string? 'symbol) #f) (test (string? '#(vector)) #f) (test (string? (current-input-port)) #f) (test (string? (current-output-port)) #f) (test (symbol? #f) #f) (test (symbol? #\c) #f) (test (symbol? 1) #f) (test (symbol? 0.1) #f) (test (symbol? '(pair)) #f) (test (symbol? (lambda () #f)) #f) (test (symbol? "string") #f) (test (symbol? 'symbol) #t) (test (symbol? '#(vector)) #f) (test (symbol? (current-input-port)) #f) (test (symbol? (current-output-port)) #f) (test (vector? #f) #f) (test (vector? #\c) #f) (test (vector? 1) #f) (test (vector? 0.1) #f) (test (vector? '(pair)) #f) (test (vector? (lambda () #f)) #f) (test (vector? "string") #f) (test (vector? 'symbol) #f) (test (vector? '#(vector)) #t) (test (vector? (current-input-port)) #f) (test (vector? (current-output-port)) #f) ; --- arithmetics --- (test (+ 0.0) 0.0) (test (+ 1.0) 1.0) (test (+ -1.0) -1.0) (test (+ 0.0 1234567890123.4) 1234567890123.4) (test (+ 1234567890123.4 0.0) 1234567890123.4) (test (+ 123.45 123.45) 246.9) (test (+ 123.45 -123.45) 0.0) (test (+ -123.45 123.45) 0.0) (test (+ -123.45 -123.45) -246.9) (test (+ 1e10 12345.67) 1.000001234567e10) (test (+ 1e10 -12345.67) 9.99998765433e9) (test (+ -1e10 12345.67) -9.99998765433e9) (test (+ -1e10 -12345.67) -1.000001234567e10) (test (+ 1e-10 12345.67) 12345.6700000001) (test (+ 1e-10 -12345.67) -12345.6699999999) (test (+ -1e-10 12345.67) 12345.6699999999) (test (+ -1e-10 -12345.67) -12345.6700000001) (test (+ 12345.67 1e10) 1.000001234567e10) (test (+ 12345.67 -1e10) -9.99998765433e9) (test (+ -12345.67 1e10) 9.99998765433e9) (test (+ -12345.67 -1e10) -1.000001234567e10) (test (+ 12345.67 1e-10) 12345.6700000001) (test (+ 12345.67 -1e-10) 12345.6699999999) (test (+ -12345.67 1e-10) -12345.6699999999) (test (+ -12345.67 -1e-10) -12345.6700000001) (test (+ 999999999.9 1) 1000000000.9) (test (+ 1 999999999.9) 1000000000.9) (test (+ 1000000000.9 -1) 999999999.9) (test (+ -1 1000000000.9) 999999999.9) (test (+ 12345.67 1234567) 1246912.67) (test (+ 12345.67 123456.7) 135802.37) (test (+ 12345.67 12345.67) 24691.34) (test (+ 12345.67 1234.567) 13580.237) (test (+ 12345.67 123.4567) 12469.1267) (test (+ 12345.67 12.34567) 12358.01567) (test (+ 12345.67 1.234567) 12346.904567) (test (+ 12345.67 .1234567) 12345.7934567) (test (+ 1234567 12345.67) 1246912.67) (test (+ 123456.7 12345.67) 135802.37) (test (+ 12345.67 12345.67) 24691.34) (test (+ 1234.567 12345.67) 13580.237) (test (+ 123.4567 12345.67) 12469.1267) (test (+ 12.34567 12345.67) 12358.01567) (test (+ 1.234567 12345.67) 12346.904567) (test (+ .1234567 12345.67) 12345.7934567) (test (+ 1.1 2.2 3.3 4.4 5.5) 16.5) (test (exact? (+ 1.0 1.0)) #f) (test (exact? (+ #i1.0 1.0)) #f) (test (exact? (+ 1.0 #i1.0)) #f) (test (exact? (+ #i1.0 #i1.0)) #f) (test (- 0.0) 0.0) (test (- 1.0) -1.0) (test (- -1.0) 1.0) (test (- 0.0 1234567890123.4) -1234567890123.4) (test (- 1234567890123.4 0.0) 1234567890123.4) (test (- 123.45 123.45) 0.0) (test (- 123.45 -123.45) 246.9) (test (- -123.45 123.45) -246.9) (test (- -123.45 -123.45) 0.0) (test (- 1e10 12345.67) 9.99998765433e9) (test (- 1e10 -12345.67) 1.000001234567e10) (test (- -1e10 12345.67) -1.000001234567e10) (test (- -1e10 -12345.67) -9.99998765433e9) (test (- 1e-10 12345.67) -12345.6699999999) (test (- 1e-10 -12345.67) 12345.6700000001) (test (- -1e-10 12345.67) -12345.6700000001) (test (- -1e-10 -12345.67) 12345.6699999999) (test (- 12345.67 1e10) -9.99998765433e9) (test (- 12345.67 -1e10) 1.000001234567e10) (test (- -12345.67 1e10) -1.000001234567e10) (test (- -12345.67 -1e10) 9.99998765433e9) (test (- 12345.67 1e-10) 12345.6699999999) (test (- 12345.67 -1e-10) 12345.6700000001) (test (- -12345.67 1e-10) -12345.6700000001) (test (- -12345.67 -1e-10) -12345.6699999999) (test (- 999999999.9 -1) 1000000000.9) (test (- -1 999999999.9) -1000000000.9) (test (- 1000000000.9 1) 999999999.9) (test (- 1 1000000000.9) -999999999.9) (test (- 12345.67 1234567) -1222221.33) (test (- 12345.67 123456.7) -111111.03) (test (- 12345.67 12345.67) 0.0) (test (- 12345.67 1234.567) 11111.103) (test (- 12345.67 123.4567) 12222.2133) (test (- 12345.67 12.34567) 12333.32433) (test (- 12345.67 1.234567) 12344.435433) (test (- 12345.67 .1234567) 12345.5465433) (test (- 1234567 12345.67) 1222221.33) (test (- 123456.7 12345.67) 111111.03) (test (- 12345.67 12345.67) 0.0) (test (- 1234.567 12345.67) -11111.103) (test (- 123.4567 12345.67) -12222.2133) (test (- 12.34567 12345.67) -12333.32433) (test (- 1.234567 12345.67) -12344.435433) (test (- .1234567 12345.67) -12345.5465433) (test (- 1.1 2.2 3.3 4.4 5.5) -14.3) (test (exact? (- 2.0 1.0)) #f) (test (exact? (- #i2.0 1.0)) #f) (test (exact? (- 2.0 #i1.0)) #f) (test (exact? (- #i2.0 #i1.0)) #f) (test (* 0.0 0.0) 0.0) (test (* 0.0 0.1) 0.0) (test (* 0.0 1.0) 0.0) (test (* 0.0 -0.0) 0.0) (test (* 0.0 -0.1) 0.0) (test (* 0.0 -1.0) 0.0) (test (* 0.1 0.0) 0.0) (test (* 0.1 0.1) 0.01) (test (* 0.1 1.0) 0.1) (test (* 0.1 -0.0) 0.0) (test (* 0.1 -0.1) -0.01) (test (* 0.1 -1.0) -0.1) (test (* 1.0 0.0) 0.0) (test (* 1.0 0.1) 0.1) (test (* 1.0 1.0) 1.0) (test (* 1.0 -0.0) 0.0) (test (* 1.0 -0.1) -0.1) (test (* 1.0 -1.0) -1.0) (test (* 123.45 123.45) 15239.9025) (test (* 123.45 -123.45) -15239.9025) (test (* -123.45 123.45) -15239.9025) (test (* -123.45 -123.45) 15239.9025) (test (* 123.45e+100 123.45e+100) 1.52399025e204) (test (* 123.45e+100 -123.45e+100) -1.52399025e204) (test (* -123.45e+100 123.45e+100) -1.52399025e204) (test (* -123.45e+100 -123.45e+100) 1.52399025e204) (test (* 123.45e-100 123.45e-100) 1.52399025e-196) (test (* 123.45e-100 -123.45e-100) -1.52399025e-196) (test (* -123.45e-100 123.45e-100) -1.52399025e-196) (test (* -123.45e-100 -123.45e-100) 1.52399025e-196) (test (* 12345.67 .1234567) 1524.155677489) (test (* 12345.67 1.234567) 15241.55677489) (test (* 12345.67 12.34567) 152415.5677489) (test (* 12345.67 123.4567) 1524155.677489) (test (* 12345.67 1234.567) 15241556.77489) (test (* 12345.67 12345.67) 152415567.7489) (test (* 12345.67 123456.7) 1.524155677489e9) (test (* 12345.67 1234567.) 1.524155677489e10) (test (* -.1234567 12345.67) -1524.155677489) (test (* -1.234567 12345.67) -15241.55677489) (test (* -12.34567 12345.67) -152415.5677489) (test (* -123.4567 12345.67) -1524155.677489) (test (* -1234.567 12345.67) -15241556.77489) (test (* -12345.67 12345.67) -152415567.7489) (test (* -123456.7 12345.67) -1.524155677489e9) (test (* -1234567. 12345.67) -1.524155677489e10) (test (* 1.0 2 3 4 5 6 7 8 9) 362880.0) (test (* 1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9) 855652.05811008) (test (/ 0.0 0.1) 0.0) (test (/ 0.0 1.0) 0.0) (test (/ 0.0 -0.1) 0.0) (test (/ 0.0 -1.0) 0.0) (test (/ 0.1 0.1) 1.0) (test (/ 0.1 1.0) 0.1) (test (/ 0.1 -0.1) -1.0) (test (/ 0.1 -1.0) -0.1) (test (/ 1.0 0.1) 10.0) (test (/ 1.0 1.0) 1.0) (test (/ 1.0 -0.1) -10.0) (test (/ 1.0 -1.0) -1.0) (test (/ 12345. 123.45) 100.0) (test (/ 12345. -123.45) -100.0) (test (/ -12345. 123.45) -100.0) (test (/ -12345. -123.45) 100.0) (test (/ 152337.3 123.4) 1234.5) (test (/ 152337.3 -123.4) -1234.5) (test (/ -152337.3 123.4) -1234.5) (test (/ -152337.3 -123.4) 1234.5) (test (/ 1.52399025e+204 123.45e+100) 123.45e+100) (test (/ -1.52399025e+204 -123.45e+100) 123.45e+100) (test (/ -1.52399025e+204 123.45e+100) -123.45e+100) (test (/ 1.52399025e+204 -123.45e+100) -123.45e+100) (test (/ 1.52399025e-196 123.45e-100) 123.45e-100) (test (/ -1.52399025e-196 -123.45e-100) 123.45e-100) (test (/ -1.52399025e-196 123.45e-100) -123.45e-100) (test (/ 1.52399025e-196 -123.45e-100) -123.45e-100) (test (/ 12345.67 .1234567) 100000.0) (test (/ 12345.67 1.234567) 10000.0) (test (/ 12345.67 12.34567) 1000.0) (test (/ 12345.67 123.4567) 100.0) (test (/ 12345.67 1234.567) 10.0) (test (/ 12345.67 12345.67) 1.0) (test (/ 12345.67 123456.7) 0.1) (test (/ 12345.67 1234567.) 0.01) (test (/ -.1234567 12345.67) -0.00001) (test (/ -1.234567 12345.67) -0.0001) (test (/ -12.34567 12345.67) -0.001) (test (/ -123.4567 12345.67) -0.01) (test (/ -1234.567 12345.67) -0.1) (test (/ -12345.67 12345.67) -1.0) (test (/ -123456.7 12345.67) -10.0) (test (/ -1234567. 12345.67) -100.0) (test (/ 1.0) 1.0) (test (/ 2.0) 0.5) (test (/ 5.0) 0.2) (test (/ 128.0 64 32 16 8 4 2 1) 6.103515625e-5) (test (< 0.0 0.0) #f) (test (< -0.0 0.0) #f) (test (< 0.0 -0.0) #f) (test (< -0.0 -0.0) #f) (test (< 1.0 1.0) #f) (test (< -1.0 1.0) #t) (test (< 1.0 -1.0) #f) (test (< -1.0 -1.0) #f) (test (< 0.1 0.1) #f) (test (< -0.1 0.1) #t) (test (< 0.1 -0.1) #f) (test (< -0.1 -0.1) #f) (test (< 123.45e+67 123.45e+67) #f) (test (< 123.45e+67 123.45e-67) #f) (test (< 123.45e-67 123.45e+67) #t) (test (< 123.45e-67 123.45e-67) #f) (test (< 123.45e+67 -123.45e+67) #f) (test (< 123.45e+67 -123.45e-67) #f) (test (< 123.45e-67 -123.45e+67) #f) (test (< 123.45e-67 -123.45e-67) #f) (test (< -123.45e+67 123.45e+67) #t) (test (< -123.45e+67 123.45e-67) #t) (test (< -123.45e-67 123.45e+67) #t) (test (< -123.45e-67 123.45e-67) #t) (test (< -123.45e+67 -123.45e+67) #f) (test (< -123.45e+67 -123.45e-67) #t) (test (< -123.45e-67 -123.45e+67) #f) (test (< -123.45e-67 -123.45e-67) #f) (test (< 0.0 0.0) #f) (test (< 1.0 0.0) #f) (test (< -1.0 0.0) #t) (test (< 0.1 0.0) #f) (test (< -0.1 0.0) #t) (test (< 1e+0 0.0) #f) (test (< -1e+0 0.0) #t) (test (< 1e-0 0.0) #f) (test (< -1e-0 0.0) #t) (test (< 1e+100 0.0) #f) (test (< -1e+100 0.0) #t) (test (< 1e-100 0.0) #f) (test (< -1e-100 0.0) #t) (test (< 1e+10000 0.0) #f) (test (< -1e+10000 0.0) #t) (test (< 1e-10000 0.0) #f) (test (< -1e-10000 0.0) #t) (test (< 0.0 0.0) #f) (test (< 0.0 1.0) #t) (test (< 0.0 -1.0) #f) (test (< 0.0 0.1) #t) (test (< 0.0 -0.1) #f) (test (< 0.0 1e+0) #t) (test (< 0.0 -1e+0) #f) (test (< 0.0 1e-0) #t) (test (< 0.0 -1e-0) #f) (test (< 0.0 1e+100) #t) (test (< 0.0 -1e+100) #f) (test (< 0.0 1e-100) #t) (test (< 0.0 -1e-100) #f) (test (< 0.0 1e+10000) #t) (test (< 0.0 -1e+10000) #f) (test (< 0.0 1e-10000) #t) (test (< 0.0 -1e-10000) #f) (test (< 1.0e14 1.0e14) #f) (test (< 1.0e14 -1.0e14) #f) (test (< -1.0e14 1.0e14) #t) (test (< -1.0e14 -1.0e14) #f) (test (< 1.0e14 1.1e14) #t) (test (< 1.0e14 -1.1e14) #f) (test (< -1.0e14 1.1e14) #t) (test (< -1.0e14 -1.1e14) #f) (test (< 1.0e-14 1.0e-14) #f) (test (< 1.0e-14 -1.0e-14) #f) (test (< -1.0e-14 1.0e-14) #t) (test (< -1.0e-14 -1.0e-14) #f) (test (< 1.0e-14 1.1e-14) #t) (test (< 1.0e-14 -1.1e-14) #f) (test (< -1.0e-14 1.1e-14) #t) (test (< -1.0e-14 -1.1e-14) #f) (test (< 1234567890123.4 1234567890123) #f) (test (< 1234567890123.4 -1234567890123) #f) (test (< -1234567890123.4 1234567890123) #t) (test (< -1234567890123.4 -1234567890123) #t) (test (< 1234567890123 1234567890123.4) #t) (test (< 1234567890123 -1234567890123.4) #f) (test (< -1234567890123 1234567890123.4) #t) (test (< -1234567890123 -1234567890123.4) #f) (test (< 1e-5 1e-4 1e-3 0.01 0.1 1.0 10.0) #t) (test (< 1e-5 1e-4 1e-3 0.01 0.1 1.0 1.0) #f) (test (< 1.0 1.0 1.0 1.0 1.0 1.0) #f) (test (<= 0.0 0.0) #t) (test (<= -0.0 0.0) #t) (test (<= 0.0 -0.0) #t) (test (<= -0.0 -0.0) #t) (test (<= 1.0 1.0) #t) (test (<= -1.0 1.0) #t) (test (<= 1.0 -1.0) #f) (test (<= -1.0 -1.0) #t) (test (<= 0.1 0.1) #t) (test (<= -0.1 0.1) #t) (test (<= 0.1 -0.1) #f) (test (<= -0.1 -0.1) #t) (test (<= 123.45e+67 123.45e+67) #t) (test (<= 123.45e+67 123.45e-67) #f) (test (<= 123.45e-67 123.45e+67) #t) (test (<= 123.45e-67 123.45e-67) #t) (test (<= 123.45e+67 -123.45e+67) #f) (test (<= 123.45e+67 -123.45e-67) #f) (test (<= 123.45e-67 -123.45e+67) #f) (test (<= 123.45e-67 -123.45e-67) #f) (test (<= -123.45e+67 123.45e+67) #t) (test (<= -123.45e+67 123.45e-67) #t) (test (<= -123.45e-67 123.45e+67) #t) (test (<= -123.45e-67 123.45e-67) #t) (test (<= -123.45e+67 -123.45e+67) #t) (test (<= -123.45e+67 -123.45e-67) #t) (test (<= -123.45e-67 -123.45e+67) #f) (test (<= -123.45e-67 -123.45e-67) #t) (test (<= 0.0 0.0) #t) (test (<= 1.0 0.0) #f) (test (<= -1.0 0.0) #t) (test (<= 0.1 0.0) #f) (test (<= -0.1 0.0) #t) (test (<= 1e+0 0.0) #f) (test (<= -1e+0 0.0) #t) (test (<= 1e-0 0.0) #f) (test (<= -1e-0 0.0) #t) (test (<= 1e+100 0.0) #f) (test (<= -1e+100 0.0) #t) (test (<= 1e-100 0.0) #f) (test (<= -1e-100 0.0) #t) (test (<= 1e+10000 0.0) #f) (test (<= -1e+10000 0.0) #t) (test (<= 1e-10000 0.0) #f) (test (<= -1e-10000 0.0) #t) (test (<= 0.0 0.0) #t) (test (<= 0.0 1.0) #t) (test (<= 0.0 -1.0) #f) (test (<= 0.0 0.1) #t) (test (<= 0.0 -0.1) #f) (test (<= 0.0 1e+0) #t) (test (<= 0.0 -1e+0) #f) (test (<= 0.0 1e-0) #t) (test (<= 0.0 -1e-0) #f) (test (<= 0.0 1e+100) #t) (test (<= 0.0 -1e+100) #f) (test (<= 0.0 1e-100) #t) (test (<= 0.0 -1e-100) #f) (test (<= 0.0 1e+10000) #t) (test (<= 0.0 -1e+10000) #f) (test (<= 0.0 1e-10000) #t) (test (<= 0.0 -1e-10000) #f) (test (<= 1.0e14 1.0e14) #t) (test (<= 1.0e14 -1.0e14) #f) (test (<= -1.0e14 1.0e14) #t) (test (<= -1.0e14 -1.0e14) #t) (test (<= 1.0e14 1.1e14) #t) (test (<= 1.0e14 -1.1e14) #f) (test (<= -1.0e14 1.1e14) #t) (test (<= -1.0e14 -1.1e14) #f) (test (<= 1.0e-14 1.0e-14) #t) (test (<= 1.0e-14 -1.0e-14) #f) (test (<= -1.0e-14 1.0e-14) #t) (test (<= -1.0e-14 -1.0e-14) #t) (test (<= 1.0e-14 1.1e-14) #t) (test (<= 1.0e-14 -1.1e-14) #f) (test (<= -1.0e-14 1.1e-14) #t) (test (<= -1.0e-14 -1.1e-14) #f) (test (<= 1234567890123.4 1234567890123) #f) (test (<= 1234567890123.4 -1234567890123) #f) (test (<= -1234567890123.4 1234567890123) #t) (test (<= -1234567890123.4 -1234567890123) #t) (test (<= 1234567890123 1234567890123.4) #t) (test (<= 1234567890123 -1234567890123.4) #f) (test (<= -1234567890123 1234567890123.4) #t) (test (<= -1234567890123 -1234567890123.4) #f) (test (<= 1e-5 1e-4 1e-3 0.01 0.1 1.0 10.0) #t) (test (<= 1e-5 1e-4 1e-3 0.01 0.1 1.0 1.0) #t) (test (<= 1.0 1.0 1.0 1.0 1.0 1.0) #t) (test (= 0.0 0.0) #t) (test (= 0.0 -0.0) #t) (test (= -0.0 0.0) #t) (test (= -0.0 -0.0) #t) (test (= 1.0 1.0) #t) (test (= 1.0 -1.0) #f) (test (= -1.0 1.0) #f) (test (= -1.0 -1.0) #t) (test (= 0.1 0.1) #t) (test (= 0.1 -0.1) #f) (test (= -0.1 0.1) #f) (test (= -0.1 -0.1) #t) (test (= 1.0 1) #t) (test (= 1 1.0) #t) (test (= 123.456e3 123456) #t) (test (= 123.456e4 1234560) #t) (test (= 123.456e5 12345600) #t) (test (= 123.456e10 1234560000000) #t) (test (= -123.456e3 -123456) #t) (test (= -123.456e4 -1234560) #t) (test (= -123.456e5 -12345600) #t) (test (= -123.456e10 -1234560000000) #t) (test (= 1.2345678901234 12345678901234.) #f) (test (= 1.2345678901234 1234567890123.4) #f) (test (= 1.2345678901234 123456789012.34) #f) (test (= 1.2345678901234 12345678901.234) #f) (test (= 1.2345678901234 1234567890.1234) #f) (test (= 1.2345678901234 123456789.01234) #f) (test (= 1.2345678901234 12345678.901234) #f) (test (= 1.2345678901234 1234567.8901234) #f) (test (= 1.2345678901234 123456.78901234) #f) (test (= 1.2345678901234 12345.678901234) #f) (test (= 1.2345678901234 1234.5678901234) #f) (test (= 1.2345678901234 123.45678901234) #f) (test (= 1.2345678901234 12.345678901234) #f) (test (= 1.2345678901234 1.2345678901234) #t) (test (= -1.2345678901234 1.2345678901234) #f) (test (= 1.2345678901234 -1.2345678901234) #f) (test (= 1.2345678901234 1.2345678901233) #f) (test (= 1.2345678901234 1.2345678901235) #f) (test (= 1e50 100000000000000000000000000000000000000000000000000) #t) (test (= 100000000000000000000000000000000000000000000000000 1e50) #t) (test (= 12345678901234.0 12345678901234) #t) (test (= 12345678901234 12345678901234.0) #t) (test (= -12345678901234.0 -12345678901234) #t) (test (= -12345678901234 -12345678901234.0) #t) (test (= 1.0 1.0 1.0 1.0 1.0 1.0 1.0) #t) (test (= 1.0 1.0 1.0 1.0 1.0 1.0 .1) #f) (test (> 0.0 0.0) #f) (test (> -0.0 0.0) #f) (test (> 0.0 -0.0) #f) (test (> -0.0 -0.0) #f) (test (> 1.0 1.0) #f) (test (> -1.0 1.0) #f) (test (> 1.0 -1.0) #t) (test (> -1.0 -1.0) #f) (test (> 0.1 0.1) #f) (test (> -0.1 0.1) #f) (test (> 0.1 -0.1) #t) (test (> -0.1 -0.1) #f) (test (> 123.45e+67 123.45e+67) #f) (test (> 123.45e+67 123.45e-67) #t) (test (> 123.45e-67 123.45e+67) #f) (test (> 123.45e-67 123.45e-67) #f) (test (> 123.45e+67 -123.45e+67) #t) (test (> 123.45e+67 -123.45e-67) #t) (test (> 123.45e-67 -123.45e+67) #t) (test (> 123.45e-67 -123.45e-67) #t) (test (> -123.45e+67 123.45e+67) #f) (test (> -123.45e+67 123.45e-67) #f) (test (> -123.45e-67 123.45e+67) #f) (test (> -123.45e-67 123.45e-67) #f) (test (> -123.45e+67 -123.45e+67) #f) (test (> -123.45e+67 -123.45e-67) #f) (test (> -123.45e-67 -123.45e+67) #t) (test (> -123.45e-67 -123.45e-67) #f) (test (> 0.0 0.0) #f) (test (> 1.0 0.0) #t) (test (> -1.0 0.0) #f) (test (> 0.1 0.0) #t) (test (> -0.1 0.0) #f) (test (> 1e+0 0.0) #t) (test (> -1e+0 0.0) #f) (test (> 1e-0 0.0) #t) (test (> -1e-0 0.0) #f) (test (> 1e+100 0.0) #t) (test (> -1e+100 0.0) #f) (test (> 1e-100 0.0) #t) (test (> -1e-100 0.0) #f) (test (> 1e+10000 0.0) #t) (test (> -1e+10000 0.0) #f) (test (> 1e-10000 0.0) #t) (test (> -1e-10000 0.0) #f) (test (> 0.0 0.0) #f) (test (> 0.0 1.0) #f) (test (> 0.0 -1.0) #t) (test (> 0.0 0.1) #f) (test (> 0.0 -0.1) #t) (test (> 0.0 1e+0) #f) (test (> 0.0 -1e+0) #t) (test (> 0.0 1e-0) #f) (test (> 0.0 -1e-0) #t) (test (> 0.0 1e+100) #f) (test (> 0.0 -1e+100) #t) (test (> 0.0 1e-100) #f) (test (> 0.0 -1e-100) #t) (test (> 0.0 1e+10000) #f) (test (> 0.0 -1e+10000) #t) (test (> 0.0 1e-10000) #f) (test (> 0.0 -1e-10000) #t) (test (> 1.0e14 1.0e14) #f) (test (> 1.0e14 -1.0e14) #t) (test (> -1.0e14 1.0e14) #f) (test (> -1.0e14 -1.0e14) #f) (test (> 1.0e14 1.1e14) #f) (test (> 1.0e14 -1.1e14) #t) (test (> -1.0e14 1.1e14) #f) (test (> -1.0e14 -1.1e14) #t) (test (> 1.0e-14 1.0e-14) #f) (test (> 1.0e-14 -1.0e-14) #t) (test (> -1.0e-14 1.0e-14) #f) (test (> -1.0e-14 -1.0e-14) #f) (test (> 1.0e-14 1.1e-14) #f) (test (> 1.0e-14 -1.1e-14) #t) (test (> -1.0e-14 1.1e-14) #f) (test (> -1.0e-14 -1.1e-14) #t) (test (> 1234567890123.4 1234567890123) #t) (test (> 1234567890123.4 -1234567890123) #t) (test (> -1234567890123.4 1234567890123) #f) (test (> -1234567890123.4 -1234567890123) #f) (test (> 1234567890123 1234567890123.4) #f) (test (> 1234567890123 -1234567890123.4) #t) (test (> -1234567890123 1234567890123.4) #f) (test (> -1234567890123 -1234567890123.4) #t) (test (> 10.0 1.0 0.1 0.01 1e-3 1e-4 1e-5) #t) (test (> 10.0 1.0 0.1 0.01 1e-3 1e-4 1e-4) #f) (test (> 1.0 1.0 1.0 1.0 1.0 1.0) #f) (test (>= 0.0 0.0) #t) (test (>= -0.0 0.0) #t) (test (>= 0.0 -0.0) #t) (test (>= -0.0 -0.0) #t) (test (>= 1.0 1.0) #t) (test (>= -1.0 1.0) #f) (test (>= 1.0 -1.0) #t) (test (>= -1.0 -1.0) #t) (test (>= 0.1 0.1) #t) (test (>= -0.1 0.1) #f) (test (>= 0.1 -0.1) #t) (test (>= -0.1 -0.1) #t) (test (>= 123.45e+67 123.45e+67) #t) (test (>= 123.45e+67 123.45e-67) #t) (test (>= 123.45e-67 123.45e+67) #f) (test (>= 123.45e-67 123.45e-67) #t) (test (>= 123.45e+67 -123.45e+67) #t) (test (>= 123.45e+67 -123.45e-67) #t) (test (>= 123.45e-67 -123.45e+67) #t) (test (>= 123.45e-67 -123.45e-67) #t) (test (>= -123.45e+67 123.45e+67) #f) (test (>= -123.45e+67 123.45e-67) #f) (test (>= -123.45e-67 123.45e+67) #f) (test (>= -123.45e-67 123.45e-67) #f) (test (>= -123.45e+67 -123.45e+67) #t) (test (>= -123.45e+67 -123.45e-67) #f) (test (>= -123.45e-67 -123.45e+67) #t) (test (>= -123.45e-67 -123.45e-67) #t) (test (>= 0.0 0.0) #t) (test (>= 1.0 0.0) #t) (test (>= -1.0 0.0) #f) (test (>= 0.1 0.0) #t) (test (>= -0.1 0.0) #f) (test (>= 1e+0 0.0) #t) (test (>= -1e+0 0.0) #f) (test (>= 1e-0 0.0) #t) (test (>= -1e-0 0.0) #f) (test (>= 1e+100 0.0) #t) (test (>= -1e+100 0.0) #f) (test (>= 1e-100 0.0) #t) (test (>= -1e-100 0.0) #f) (test (>= 1e+10000 0.0) #t) (test (>= -1e+10000 0.0) #f) (test (>= 1e-10000 0.0) #t) (test (>= -1e-10000 0.0) #f) (test (>= 0.0 0.0) #t) (test (>= 0.0 1.0) #f) (test (>= 0.0 -1.0) #t) (test (>= 0.0 0.1) #f) (test (>= 0.0 -0.1) #t) (test (>= 0.0 1e+0) #f) (test (>= 0.0 -1e+0) #t) (test (>= 0.0 1e-0) #f) (test (>= 0.0 -1e-0) #t) (test (>= 0.0 1e+100) #f) (test (>= 0.0 -1e+100) #t) (test (>= 0.0 1e-100) #f) (test (>= 0.0 -1e-100) #t) (test (>= 0.0 1e+10000) #f) (test (>= 0.0 -1e+10000) #t) (test (>= 0.0 1e-10000) #f) (test (>= 0.0 -1e-10000) #t) (test (>= 1.0e14 1.0e14) #t) (test (>= 1.0e14 -1.0e14) #t) (test (>= -1.0e14 1.0e14) #f) (test (>= -1.0e14 -1.0e14) #t) (test (>= 1.0e14 1.1e14) #f) (test (>= 1.0e14 -1.1e14) #t) (test (>= -1.0e14 1.1e14) #f) (test (>= -1.0e14 -1.1e14) #t) (test (>= 1.0e-14 1.0e-14) #t) (test (>= 1.0e-14 -1.0e-14) #t) (test (>= -1.0e-14 1.0e-14) #f) (test (>= -1.0e-14 -1.0e-14) #t) (test (>= 1.0e-14 1.1e-14) #f) (test (>= 1.0e-14 -1.1e-14) #t) (test (>= -1.0e-14 1.1e-14) #f) (test (>= -1.0e-14 -1.1e-14) #t) (test (>= 1234567890123.4 1234567890123) #t) (test (>= 1234567890123.4 -1234567890123) #t) (test (>= -1234567890123.4 1234567890123) #f) (test (>= -1234567890123.4 -1234567890123) #f) (test (>= 1234567890123 1234567890123.4) #f) (test (>= 1234567890123 -1234567890123.4) #t) (test (>= -1234567890123 1234567890123.4) #f) (test (>= -1234567890123 -1234567890123.4) #t) (test (>= 10.0 1.0 0.1 0.01 1e-3 1e-4 1e-5) #t) (test (>= 10.0 1.0 0.1 0.01 1e-3 1e-4 1e-4) #t) (test (>= 1.0 1.0 1.0 1.0 1.0 1.0) #t) (test (abs 1.234567890) 1.23456789) (test (abs 1.234567890) 1.23456789) (test (abs 0.0) 0.0) (test (abs -0.0) 0.0) (test (< 1.570796320 (acos 0.00) 1.570796329) #t) (test (< 1.318116070 (acos 0.25) 1.318116079) #t) (test (< 1.047197550 (acos 0.50) 1.047197559) #t) (test (< 0.722734240 (acos 0.75) 0.722734249) #t) (test (< 3.141592650 (acos -1.00) 3.141592659) #t) (test (< 2.418858400 (acos -0.75) 2.418858409) #t) (test (< 2.094395100 (acos -0.50) 2.094395109) #t) (test (< 1.823476580 (acos -0.25) 1.823476589) #t) (test (acos 1) 0) (test (asin 0) 0.0) (test (< 0.252680250 (asin 0.25) 0.252680259) #t) (test (< 0.523598770 (asin 0.50) 0.523598779) #t) (test (< 0.848062070 (asin 0.75) 0.848062079) #t) (test (< 1.570796320 (asin 1.00) 1.570796329) #t) (test (< -1.570796329 (asin -1.00) -1.570796320) #t) (test (< -0.848062079 (asin -0.75) -0.848062070) #t) (test (< -0.523598779 (asin -0.50) -0.523598770) #t) (test (< -0.252680259 (asin -0.25) -0.252680250) #t) (test (atan 0) 0.0) (test (< 0.244978660 (atan 0.25) 0.244978669) #t) (test (< 0.463647600 (atan 0.50) 0.463647610) #t) (test (< 0.643501100 (atan 0.75) 0.643501109) #t) (test (< 0.785398160 (atan 1.00) 0.785398169) #t) (test (< -0.244978669 (atan -0.25) -0.244978660) #t) (test (< -0.463647610 (atan -0.50) -0.463647600) #t) (test (< -0.643501109 (atan -0.75) -0.643501100) #t) (test (< -0.785398169 (atan -1.00) -0.785398160) #t) (test (ceiling 0.0) 0.0) (test (ceiling 1.0) 1.0) (test (ceiling -1.0) -1.0) (test (ceiling 1.1) 2.0) (test (ceiling 1.4) 2.0) (test (ceiling 1.5) 2.0) (test (ceiling 1.9) 2.0) (test (ceiling -1.1) -1.0) (test (ceiling -1.4) -1.0) (test (ceiling -1.5) -1.0) (test (ceiling -1.9) -1.0) (define pi 3.14159265358979323846264338327950288419716939937510) (define pi/4 (/ pi 4)) (define pi/2 (/ pi 2)) (define 3pi/4 (+ pi/2 pi/4)) (define 3pi/2 (+ pi pi/2)) (define 5pi/4 (+ pi pi/4)) (define 7pi/4 (+ pi 3pi/4)) (define 2pi (+ pi pi)) (test (cos 0.0) 1.0) (test (cos pi/2) 0.0) (test (cos pi ) -1.0) (test (cos 3pi/2) 0.0) (test (cos 2pi ) 1.0) (test (< 0.7071067810 (cos pi/4) 0.7071067819) #t) (test (< -0.7071067819 (cos 3pi/4) -0.7071067810) #t) (test (< -0.7071067819 (cos 5pi/4) -0.7071067810) #t) (test (< 0.7071067810 (cos 7pi/4) 0.7071067819) #t) (test (< 0.1699671420 (cos 1.4) 0.1699671430) #t) (test (< -0.9422223409 (cos 2.8) -0.9422223400) #t) (test (< -0.4902608219 (cos 4.2) -0.4902608210) #t) (test (< 0.7755658780 (cos 5.6) 0.7755658789) #t) (test (exact->inexact #e0.0) #i0) (test (exact->inexact #i0.0) #i0) (test (exact->inexact #e-0.0) #i0) (test (exact->inexact #i-0.0) #i0) (test (exact->inexact #e1.0) #i1) (test (exact->inexact #i1.0) #i1) (test (exact->inexact #e-1.0) #i-1) (test (exact->inexact #i-1.0) #i-1) (test (exact->inexact #e1.0) #i1.0) (test (exact->inexact #i1.1) #i1.1) (test (exact->inexact #e-1.0) #i-1.0) (test (exact->inexact #i-1.1) #i-1.1) (test (exact? (exact->inexact 0)) #f) (test (exact? (exact->inexact 1)) #f) (test (exact? (exact->inexact -1)) #f) (test (exact? (exact->inexact 12345678901234567890)) #f) (test (exact? (exact->inexact -12345678901234567890)) #f) (test (exact? (exact->inexact 0.0)) #f) (test (exact? (exact->inexact -0.0)) #f) (test (exact? (exact->inexact 0.1)) #f) (test (exact? (exact->inexact -0.1)) #f) (test (exact? (exact->inexact 1.0)) #f) (test (exact? (exact->inexact -1.0)) #f) (test (exact? (exact->inexact 1234567890.1234)) #f) (test (exact? (exact->inexact -1234567890.1234)) #f) (test (exact? (exact->inexact 0.1234567890123)) #f) (test (exact? (exact->inexact -0.1234567890123)) #f) (test (exact? (exact->inexact 1.2345e+100)) #f) (test (exact? (exact->inexact 1.2345e-100)) #f) (test (exact? (exact->inexact -1.2345e+100)) #f) (test (exact? (exact->inexact -1.2345e-100)) #f) (test (exact? 0) #t) (test (exact? 1) #t) (test (exact? -1) #t) (test (exact? 12345678901234567890) #t) (test (exact? -12345678901234567890) #t) (test (exact? 0.0) #f) (test (exact? -0.0) #f) (test (exact? 0.1) #f) (test (exact? -0.1) #f) (test (exact? 1.0) #f) (test (exact? -1.0) #f) (test (exact? 1234567890.1234) #f) (test (exact? -1234567890.1234) #f) (test (exact? 0.1234567890123) #f) (test (exact? -0.1234567890123) #f) (test (exact? 1.2345e+100) #f) (test (exact? 1.2345e-100) #f) (test (exact? -1.2345e+100) #f) (test (exact? -1.2345e-100) #f) (test (exact? #i0) #f) (test (exact? #i1) #f) (test (exact? #i-1) #f) (test (exact? #i12345678901234567890) #f) (test (exact? #i-12345678901234567890) #f) (test (exact? #i0.0) #f) (test (exact? #i-0.0) #f) (test (exact? #i0.1) #f) (test (exact? #i-0.1) #f) (test (exact? #i1.0) #f) (test (exact? #i-1.0) #f) (test (exact? #i1234567890.1234) #f) (test (exact? #i-1234567890.1234) #f) (test (exact? #i0.1234567890123) #f) (test (exact? #i-0.1234567890123) #f) (test (exact? #i1.2345e+100) #f) (test (exact? #i1.2345e-100) #f) (test (exact? #i-1.2345e+100) #f) (test (exact? #i-1.2345e-100) #f) (test (exp 0) 1.0) (test (< 1.6487212700 (exp 0.5) 1.6487212709) #t) (test (< 2.7182818280 (exp 1.0) 2.7182818289) #t) (test (< 7.3890560980 (exp 2.0) 7.3890560990) #t) (test (< 20.085536920 (exp 3.0) 20.085536929) #t) (test (expt 2.0 2.0) 4.0) (test (expt 0. 2) 0.0) (test (expt 2.0 0) 1) (test (expt 2.0 1) 2.0) (test (expt 2.0 2) 4.0) (test (expt 2.0 3) 8.0) (test (expt -2.0 3) -8.0) (test (expt -2.0 4) 16.0) (test (expt 2.5 5) 97.65625) (test (expt -2.5 5) -97.65625) (test (expt 0 0) 1) (test (expt 0 1) 0) (test (expt 0 0.1) 0) (test (number? (expt 0 0.0)) #f) (test (number? (expt 0 -0.1)) #f) (test (expt 1 -1) 1.0) (test (expt 2 -1) 0.5) (test (expt -2 -1) -0.5) (test (expt 2 -1) 0.5) (test (expt 2 -2) 0.25) (test (expt -2 -2) 0.25) (test (expt 2 -3) 0.125) (test (expt -2 -3) -0.125) (test (expt 2 -10) 0.0009765625) (test (expt -2 -10) 0.0009765625) (test (expt 10 -1000) 1.0e-1000) (test (floor 0.0) 0.0) (test (floor 1.0) 1.0) (test (floor -1.0) -1.0) (test (floor 1.1) 1.0) (test (floor 1.4) 1.0) (test (floor 1.5) 1.0) (test (floor 1.9) 1.0) (test (floor -1.1) -2.0) (test (floor -1.4) -2.0) (test (floor -1.5) -2.0) (test (floor -1.9) -2.0) (test (inexact->exact #e0.0) 0) (test (inexact->exact #i0.0) 0) (test (inexact->exact #e-0.0) 0) (test (inexact->exact #i-0.0) 0) (test (inexact->exact #e1.0) 1) (test (inexact->exact #i1.0) 1) (test (inexact->exact #e-1.0) -1) (test (inexact->exact #i-1.0) -1) (test (inexact->exact #e1.0) 1) (test (inexact->exact #i1.0) 1) (test (inexact->exact #e-1.0) -1) (test (inexact->exact #i-1.0) -1) (test (exact? (inexact->exact #i0)) #t) (test (exact? (inexact->exact #i1)) #t) (test (exact? (inexact->exact #i-1)) #t) (test (exact? (inexact->exact #i1234567890)) #t) (test (exact? (inexact->exact #i-1234567890)) #t) (test (exact? (inexact->exact #i0.0)) #t) (test (exact? (inexact->exact #i-0.0)) #t) (test (exact? (inexact->exact #i1.0)) #t) (test (exact? (inexact->exact #i-1.0)) #t) (test (inexact? 0) #f) (test (inexact? 1) #f) (test (inexact? -1) #f) (test (inexact? 12345678901234567890) #f) (test (inexact? -12345678901234567890) #f) (test (inexact? 0.0) #t) (test (inexact? -0.0) #t) (test (inexact? 0.1) #t) (test (inexact? -0.1) #t) (test (inexact? 1.0) #t) (test (inexact? -1.0) #t) (test (inexact? 1234567890.1234) #t) (test (inexact? -1234567890.1234) #t) (test (inexact? 0.1234567890123) #t) (test (inexact? -0.1234567890123) #t) (test (inexact? 1.2345e+100) #t) (test (inexact? 1.2345e-100) #t) (test (inexact? -1.2345e+100) #t) (test (inexact? -1.2345e-100) #t) (test (inexact? #i0) #t) (test (inexact? #i1) #t) (test (inexact? #i-1) #t) (test (inexact? #i12345678901234567890) #t) (test (inexact? #i-12345678901234567890) #t) (test (inexact? #i0.0) #t) (test (inexact? #i-0.0) #t) (test (inexact? #i0.1) #t) (test (inexact? #i-0.1) #t) (test (inexact? #i1.0) #t) (test (inexact? #i-1.0) #t) (test (inexact? #i1234567890.1234) #t) (test (inexact? #i-1234567890.1234) #t) (test (inexact? #i0.1234567890123) #t) (test (inexact? #i-0.1234567890123) #t) (test (inexact? #i1.2345e+100) #t) (test (inexact? #i1.2345e-100) #t) (test (inexact? #i-1.2345e+100) #t) (test (inexact? #i-1.2345e-100) #t) (test (log 1) 0.0) (test (< -2.3025850930 (log 0.1) -2.3025850920) #t) (test (< 0.6931471800 (log 2.0) 0.6931471809) #t) (test (< 1.0986122880 (log 3.0) 1.0986122889) #t) (test (min 2 1 -2 -1 3) -2) (test (exact? (min 2 1 -2 -1 3)) #t) (test (min -2.0 1 -2 -1 3) -2.0) (test (inexact? (min -2.0 1 -2 -1 3)) #t) (test (max 2 -2 5 -1 3) 5) (test (exact? (max 2 -2 5 -1 3)) #t) (test (max 2 -2 5 -1 3.0) 5.0) (test (inexact? (max 2 -2 5 -1 3.0)) #t) (test (negative? -1.0) #t) (test (negative? -0.1) #t) (test (negative? 0.0) #f) (test (negative? -0.0) #f) (test (negative? 0.1) #f) (test (negative? 1.0) #f) (test (negative? -1e+100) #t) (test (negative? 1e+100) #f) (test (negative? -1e-100) #t) (test (negative? 1e-100) #f) (test (positive? -1.0) #f) (test (positive? -0.1) #f) (test (positive? 0.0) #f) (test (positive? -0.0) #f) (test (positive? 0.1) #t) (test (positive? 1.0) #t) (test (positive? -1e+100) #f) (test (positive? 1e+100) #t) (test (positive? -1e-100) #f) (test (positive? 1e-100) #t) (test (round 0.0) 0.0) (test (round 1.0) 1.0) (test (round -1.0) -1.0) (test (round 1.1) 1.0) (test (round 1.4) 1.0) (test (round 1.5) 2.0) (test (round 1.9) 2.0) (test (round -1.1) -1.0) (test (round -1.4) -1.0) (test (round -1.5) -2.0) (test (round -1.9) -2.0) (test (sin 0.0) 0.0) (test (sin pi/2) 1.0) (test (sin pi ) 0.0) (test (sin 3pi/2) -1.0) (test (sin 2pi) 0.0) (test (< 0.7071067810 (sin pi/4) 0.7071067819) #t) (test (< 0.7071067810 (sin 3pi/4) 0.7071067819) #t) (test (< -0.7071067819 (sin 5pi/4) -0.7071067810) #t) (test (< -0.7071067819 (sin 7pi/4) -0.7071067810) #t) (test (< 0.9854497290 (sin 1.4) 0.9854497300) #t) (test (< 0.3349881500 (sin 2.8) 0.3349881509) #t) (test (< -0.8715757729 (sin 4.2) -0.8715757720) #t) (test (< -0.6312666379 (sin 5.6) -0.6312666370) #t) (test (sqrt 0) 0) (test (sqrt 1) 1.0) (test (sqrt 144) 12.0) (test (sqrt 144.0) 12.0) (test (sqrt 15241578750190521) 123456789.0) (test (< 1.4142135620 (sqrt 2) 1.4142135629) #t) (test (< 11.090536500 (sqrt 123) 11.090536509) #t) (test (sqrt 15239.9025) 123.45) (test (sqrt 1e200) 1e100) (test (tan 0.0) 0.0) (test (tan pi/4) 1.0) (test (tan 3pi/4) -1.0) (test (tan 5pi/4) 1.0) (test (tan 7pi/4) -1.0) (test (tan 2pi ) 0.0) (test (< 5.7978837150 (tan 1.4) 5.7978837159) #t) (test (< -0.3555298319 (tan 2.8) -0.3555298310) #t) (test (< 1.7777797740 (tan 4.2) 1.7777797749) #t) (test (< -0.8139432839 (tan 5.6) -0.8139432830) #t) (test (truncate 0.0) 0.0) (test (truncate 1.0) 1.0) (test (truncate -1.0) -1.0) (test (truncate 1.1) 1.0) (test (truncate 1.4) 1.0) (test (truncate 1.5) 1.0) (test (truncate 1.9) 1.0) (test (truncate -1.1) -1.0) (test (truncate -1.4) -1.0) (test (truncate -1.5) -1.0) (test (truncate -1.9) -1.0) (test (zero? -1.0) #f) (test (zero? -0.1) #f) (test (zero? 0.0) #t) (test (zero? -0.0) #t) (test (zero? 0.1) #f) (test (zero? 1.0) #f) (test (zero? 1e+100) #f) (test (zero? 1e-100) #f) (test (zero? -1e+100) #f) (test (zero? -1e-100) #f) ; --- equivalence --- (test (eqv? 1 1.0) #f) (test (eqv? 1.0 1 ) #f) (test (eqv? 1.0 1.0) #t) (test (equal? 1.0 1 ) #f) (test (equal? 1 1.0) #f) (test (equal? 1.0 1.0) #t) ; --- strings --- (test (number->string 1.0) "1.0") (test (number->string 123.0) "123.0") (test (number->string 123.45) "123.45") (test (number->string 1.23e2) "123.0") (test (number->string 1.23e5) "123000.0") (test (number->string 3.1415926535) "3.1415926535") (test (number->string 123456789.5) "123456789.5") (test (number->string 1234567890.1) "1.2345678901e+9") (test (number->string 12345.67e100) "1.234567e+104") (test (number->string 1.23450) "1.2345") (test (number->string 0.12345) "0.12345") (test (number->string 0.012345) "0.012345") (test (number->string 0.0012345) "0.0012345") (test (number->string 0.00012345) "0.00012345") (test (number->string 0.000012345) "1.2345e-5") (test (number->string 12345e-100) "1.2345e-96") (test (number->string -1.0) "-1.0") (test (number->string -123.0) "-123.0") (test (number->string -123.45) "-123.45") (test (number->string -3.1415926535) "-3.1415926535") (test (number->string -123456789.5) "-123456789.5") (test (number->string -1234567890.1) "-1.2345678901e+9") (test (number->string -12345.67e100) "-1.234567e+104") (test (number->string -1.23450) "-1.2345") (test (number->string -0.12345) "-0.12345") (test (number->string -0.012345) "-0.012345") (test (number->string -0.0012345) "-0.0012345") (test (number->string -0.00012345) "-0.00012345") (test (number->string -0.000012345) "-1.2345e-5") (test (number->string -12345e-100) "-1.2345e-96") (test (string->number "+1 ") #f) (test (string->number "-1 ") #f) (test (string->number "0.0") 0.0) (test (string->number "-0.0") -0.0) (test (string->number "1.0") 1.0) (test (string->number "-1.0") -1.0) (test (string->number "12345.0") 12345.0) (test (string->number "-12345.0") -12345.0) (test (string->number "1.2345") 1.2345) (test (string->number "-1.2345") -1.2345) (test (string->number "0.12345") 0.12345) (test (string->number "-0.12345") -0.12345) (test (string->number "-0.00012345") -0.00012345) (test (string->number "0.1") 0.1) (test (string->number "0.01") 0.01) (test (string->number "0.001") 0.001) (test (string->number "0.0000000000001") 0.0000000000001) (test (string->number "1e0") 1.0) (test (string->number "1e-0") 1.0) (test (string->number "1e1") 10.0) (test (string->number "1e2") 100.0) (test (string->number "1e5") 100000.0) (test (string->number "1e10") 10000000000.0) (test (string->number "1e-1") 0.1) (test (string->number "1e-2") 0.01) (test (string->number "1e-5") 0.00001) (test (string->number "1e-10") 0.0000000001) (test (string->number "123.456e0") 123.456) (test (string->number "123.456e1") 1234.56) (test (string->number "123.456e2") 12345.6) (test (string->number "123.456e3") 123456.0) (test (string->number "123.456e4") 1234560.0) (test (string->number "123.456e5") 12345600.0) (test (string->number "123.456e10") 1234560000000.0) (test (string->number "-123.456e0") -123.456) (test (string->number "-123.456e1") -1234.56) (test (string->number "-123.456e2") -12345.6) (test (string->number "-123.456e3") -123456.0) (test (string->number "-123.456e4") -1234560.0) (test (string->number "-123.456e5") -12345600.0) (test (string->number "-123.456e10") -1234560000000.0) (test (string->number "123.456e-1") 12.3456) (test (string->number "123.456e-2") 1.23456) (test (string->number "123.456e-3") 0.123456) (test (string->number "123.456e-4") 0.0123456) (test (string->number "123.456e-5") 0.00123456) (test (string->number "123.456e-10") 0.0000000123456) (test (string->number "-123.456e-1") -12.3456) (test (string->number "-123.456e-2") -1.23456) (test (string->number "-123.456e-3") -0.123456) (test (string->number "-123.456e-4") -0.0123456) (test (string->number "-123.456e-5") -0.00123456) (test (string->number "-123.456e-10") -0.0000000123456) (test (string->number "+123.45e+678") 123.45e678) (test (string->number "-123.45e+678") -123.45e678) (test (string->number "+123.45e-678") 123.45e-678) (test (string->number "-123.45e-678") -123.45e-678) (test (string->number "1.") 1.0) (test (string->number ".1") 0.1) (test (string->number "1.e1") 10.0) (test (string->number ".1e1") 1.0) (test (string->number "1000e0") 1e3) (test (string->number "100e1") 1e3) (test (string->number "10e2") 1e3) (test (string->number "1e3") 1e3) (test (string->number ".1e4") 1e3) (test (string->number ".01e5") 1e3) (test (string->number ".001e6") 1e3) (test (string->number "12345678.901d10") 1.2345678901e+17) (test (string->number "12345678.901e10") 1.2345678901e+17) (test (string->number "12345678.901f10") 1.2345678901e+17) (test (string->number "12345678.901l10") 1.2345678901e+17) (test (string->number "12345678.901s10") 1.2345678901e+17) (test (string->number "12345678.901D10") 1.2345678901e+17) (test (string->number "12345678.901E10") 1.2345678901e+17) (test (string->number "12345678.901F10") 1.2345678901e+17) (test (string->number "12345678.901L10") 1.2345678901e+17) (test (string->number "12345678.901S10") 1.2345678901e+17) (test (string->number "1 ") #f) (test (string->number "1.1 ") #f) (test (string->number "1.1e1 ") #f) (test (string->number "1e") #f) (test (string->number "1e+") #f) (test (string->number "1e-") #f) (test (string->number "1.e") #f) (test (string->number "e1") #f) (test (string->number "+e1") #f) (test (string->number "-e1") #f) (test (string->number ".e1") #f) (test (string->number "+.e1") #f) (test (string->number "-.e1") #f) (test (string->number ".") #f) (test (string->number "1x1") #f) (test (string->number "1.x1") #f) (test (string->number "1.1x1") #f) (test (string->number "#b100") 4) (test (string->number "#o100") 64) (test (string->number "#d100") 100) (test (string->number "#x100") 256) (test (string->number "#e100.0") 100) (test (string->number "#i100") 100.0) (test (string->number "#e100.1") #f) (test (inexact? (string->number "#i100")) #t) (test (string->number "+###") 555.0) (test (string->number "-###") -555.0) (test (string->number "-#.#") -5.5) (test (string->number "+#.#") 5.5) (test (string->number ".###") 0.555) (test (string->number "1#.#4") 15.54) (test (string->number "#") #f) (test (string->number "###") #f) (test (string->number "#.#") #f) (test (string->number "#23") #f) (test (inexact? (string->number "+###")) #t) ; --- I/O --- (define (visibility-check x) (if (file-exists? testfile) (delete-file testfile)) (let ((out (open-output-file testfile))) (write x out) (display #\space out) (display x out) (display #\space out) (write 'the-end out) (close-output-port out) (let ((in (open-input-file testfile))) (let ((vis (read in))) (let ((invis (read in))) (close-input-port in) (list vis invis)))))) (test (visibility-check 1.0) '(1.0 1.0)) (test (visibility-check 12345.6789e+10) '(12345.6789e+10 12345.6789e+10)) (test (visibility-check -12345.6789e+10) '(-12345.6789e+10 -12345.6789e+10)) (test (visibility-check 12345.6789e-10) '(12345.6789e-10 12345.6789e-10)) (test (visibility-check -12345.6789e-10) '(-12345.6789e-10 -12345.6789e-10)) (delete-file testfile) (cond ((zero? Errors) (display "Everything fine!")) (else (display Errors) (if (> Errors 1) (display " errors.") (display " error.")))) (display #\newline) (if (file-exists? testfile) (delete-file testfile)) s9/util/pagetail000644 001751 001751 00000000065 11777025205 013516 0ustar00nmhnmh000000 000000

contact

s9/util/pagehead000644 001751 001751 00000000210 12051122363 013443 0ustar00nmhnmh000000 000000
http://t3x.org/@dir/@file.html
s9/util/procedures.scm000644 001751 001751 00000002603 13042102013 014640 0ustar00nmhnmh000000 000000 ; Ad-hoc procedure list generator ; To be run in help/ (define (scan) (map (lambda (x) (if (sys:stat-directory? x) (begin (sys:chdir x) (let ((d (scan))) (sys:chdir "..") d)) (with-input-from-file x (lambda () (let loop ((ln (read-line)) (fns '())) (if (or (eof-object? ln) (string=? "" ln)) (reverse! fns) (let ((ln (and-let* ((ln (string-find "(" ln)) ;) (p (string-position " " ln)) (ln (substring ln 1 p)) (k (- (string-length ln) 1)) (ln (if (char=? #\) ;( (string-ref ln k)) (substring ln 0 k) ln))) ln))) (if ln (loop (read-line) (cons ln fns)) (loop (read-line) fns))))))))) (sys:readdir "."))) (display (sort string<=? (list->set (flatten (scan))))) (newline) s9/util/blurb000644 001751 001751 00000002316 13201115500 013015 0ustar00nmhnmh000000 000000

S9fES is a mature, portable, and comprehensible interpreter for R4RS Scheme. The core interpreter is written in pure ANSI C (C89), so it runs on all platforms offering a C compiler. It can even be compiled natively on Plan 9. On Unix-based systems (or MinGW), it also offers an interface to common Unix system calls and Curses routines.

The interpreter is built around the S9core toolkit (download), which contains some basic building blocks for dynamic languages, such as a garbage collected heap, bignum arithmetics, etc. (The toolkit is included in the S9fES tarball).

S9fES has been developed using EDOC, a literate programming tool. The rendered EDOC source code to a previous version is available in print and PDF form. The C and Scheme code stripped from the EDOC files is in the public domain, though, and can be downloaded here (~600KB).

The interpreter is explained in detail in the Scheme 9 Book!

The S9fES Distribution Archive

s9/util/mktoc.sed000644 001751 001751 00000000443 12530036364 013613 0ustar00nmhnmh000000 000000 s/C;.*\...*\...*;\(.*\);\(..\)$/\\f[HI]\1 \2\\fP/p s/C;.*\...*\...*;\(.*\);\(.\)$/\\f[HI]\1 \\h'\\w'0'u'\2\\fP/p s/C;.*\...*;\(.*\);\(..\)$/\1 \2/p s/C;.*\...*;\(.*\);\(.\)$/\1 \\h'\\w'0'u'\2/p s/C;.*\.;\(.*\);\(..\)$/\\f[HB]\1 \2\\fP/p s/C;.*\.;\(.*\);\(.\)$/\\f[HB]\1 \\h'\\w'0'u'\2\\fP/p s9/util/book000644 001751 001751 00000004236 12533375307 012670 0ustar00nmhnmh000000 000000 .ad b .ft H .nh .nr VV 1 \" verbose flag .nr CN 0 \" chapter number .nr FN 0 \" figure number .pl 9i .ll 4.5i .po 0.75i .ps 11p .vs 14p .wh 0 BB .wh -0.75i EP .de X .tm R;.nr \\$1 \\n% .. .de B \f[HB]\\$1\f[]\\$2 .. .de I \f[HI]\\$1\f[]\\$2 .. .de K \f[CB]\\$1\fP\\$2 .. .de AB .ce \s36\\$1\s0 .sp .ce \s14\\$2\s0 .. .de LB \" begin list .br .in +\w'\(bu 'u .. .de LE \" end list .br .in -\w'\(bu 'u .. .de LI \" list element .sp 0.4v .ti -\w'\(bu 'u \(bu\h'|0'\h'\w'\(bu 'u'\\$1 .. .de SG .sp 0.4v \s+1\f[I]\\$1\ \ \ \(->\ \ \ \\$2\f[]\s0 .. .de SB .sp 0.4v .ft I .ps +1 .. .de SE .ft .ps -1 .. .de CB .sp 0.4v .ft CB .ad b .nf .. .de CE .ft .fi .ad b .. .de CO .sp 0.4v \f[CB]\\$1\f[] .. .de AR \ \ \(-> \ \ .. .de U \\$1\v'+0.25v'\s-3\\$2\s0\v'-0.25v'\\$3 .. .de UU \s+1\f[I]\\$1\v'+0.25v'\s-3\\$2\s0\v'-0.25v'\\$3\s-1\f[] .. .de VA \f[I]\s+1\\$1\f[]\s0\\$2 .. .de VL \\$1\f[I]\s+1\\$2\f[]\s0\\$3 .. .de FO .sp 0.4v \s+1\f[I]\\$1\f[]\s0 .. .de EE .sp 0.4v \\$1 .. .de FB .sp 0.4v .ft I .ps +1 .ad n .. .de FE .ft P .ps -1 .ad b .. .de TL .ds PT "\\$1 .. .de S .sp 0.4v .. .de BP \" begin page .ev 1 .ft H .sp 0.4i .lt 4.5i .if o .tl '\s-3\\*(PT\s0''\s12%' .if e .tl '\s12%''\s-3\\*(PT\s0' .sp 0.3i .ev .. .de BB \" begin blank page .ev 1 .ft H .sp 0.4i .lt 4.5i .\" .if o .tl '''\s12%' .\" .if e .tl '\s12%''' .sp 0.4i .ev .. .de EP \" End of page 'bp .. .de PA \" Begin Paragraph .sp 0.4v .if \\n(.t<2v .bp .ft H .di PX .. .de PQ \" End [tagged] paragraph .br .di .nr d1 \\n(dn/1v-1 .nr d2 \\n(d1-1 .nr t1 \\n(.t/1v .if \\n(d1>=\\n(t1 \{ \ .if \\n(d2<=\\n(t1 .sp 0v \} .nf .PX .rr d1 .rr d2 .rr t1 .fi .. .de HD \" Heading .ev 2 .ft H .nr CN \\n(CN+1 .wh 0 .\" .if \\n%>1 \{ .\" .bp .\" .sp 0.5i \} .TL "\\$1" .nf .vs 40 .\" .if e .bp .if e \{\ \s28\\$1\s0 \} .if o \{\ \h'4.5i-\w'\s28\\$1\s0'u'\s28\\$1\s0 \} .fi .\" .sp 0.2v .nr SN 0 .nr UN 0 .wh 0 BP .if \\n(VV .tm C;\\n(CN.;\\$1;\\n% .ev .. .de SH \" Subheading .br .ev 2 .ft H .TL "\\$1" .nr SN \\n(SN+1 .nr UN 0 .nf \s18\\$1\s0 .\" .sp 0.2v .ev .if \\n(VV .tm C;\\n(CN.\\n(SN;\\$1;\\n% .. .de SU \" Sub-subheading .br .ev 2 .ft H .TL "\\$1" .nr UN \\n(UN+1 .nf \s14\\$1\s0 .ev .if \\n(VV .tm C;\\n(CN.\\n(SN.\\n(UN;\\$1;\\n% .. s9/util/s9.rc000644 001751 001751 00000000505 12545013163 012657 0ustar00nmhnmh000000 000000 #!/bin/rc # S9 startup script # based on a script in this article: # http://ninetimes.cat-v.org/tips/2009/07/19/0/ s9dir=$home/lib/s9fes mkdir -p $home/lib/s9fes for (i in . $objtype lib ext contrib) bind -a $s9dir/$i $home/lib/s9fes S9FES_LIBRARY_PATH=$home/lib/s9fes /$objtype/bin/s9fes $* unmount $home/lib/s9fes s9/util/fix-help-files000644 001751 001751 00000031027 12550776205 014551 0ustar00nmhnmh000000 000000 #!/bin/rc # Run this script in the S9 root to fix help files on Plan 9 cd help || exit 1 cp amb amb-collector cp amb amb-donep cp amb amb-reset cp assq assoc cp assq assv cp bit0 bitstar cp bit0 bitstarc cp bit0 bita cp bit0 bitcstar cp bit0 bitb cp bit0 bitneq cp bit0 bitplus cp bit0 bitnplus cp bit0 biteq cp bit0 bitcb cp bit0 bitplusc cp bit0 bitca cp bit0 bitcplus cp bit0 bitnstar cp bit0 bit1 cp bit0 bitsl cp bit0 bitsr cp bitwise-and bitwise-1 cp bitwise-and bitwise-2 cp bitwise-and bitwise-and-c1 cp bitwise-and bitwise-and-c2 cp bitwise-and bitwise-and-not cp bitwise-and bitwise-c1 cp bitwise-and bitwise-c2 cp bitwise-and bitwise-clear cp bitwise-and bitwise-or cp bitwise-and bitwise-or-c1 cp bitwise-and bitwise-or-c2 cp bitwise-and bitwise-or-not cp bitwise-and bitwise-set cp bitwise-and bitwise-shift-left cp bitwise-and bitwise-shift-right cp bitwise-and bitwise-xor cp bitwise-and bitwise-xor-not cp caar caaaar cp caar caaadr cp caar caaar cp caar caadar cp caar caaddr cp caar caadr cp caar cadaar cp caar cadadr cp caar cadar cp caar caddar cp caar cadddr cp caar caddr cp caar cadr cp caar cdaaar cp caar cdaadr cp caar cdaar cp caar cdadar cp caar cdaddr cp caar cdadr cp caar cdar cp caar cddaar cp caar cddadr cp caar cddar cp caar cdddar cp caar cddddr cp caar cdddr cp caar cddr cp call-with-current-continuation callslashcc cp call-with-input-file call-with-output-file cp catch throw cp char-alphabeticp char-lower-casep cp char-alphabeticp char-numericp cp char-alphabeticp char-upper-casep cp char-alphabeticp char-whitespacep cp char-cieqp char-cigep cp char-cieqp char-cigtp cp char-cieqp char-cilep cp char-cieqp char-ciltp cp char-to-integer integer-to-char cp char-upcase char-downcase cp chareqp chargep cp chareqp chargtp cp chareqp charlep cp chareqp charltp cp close-input-port close-output-port cp combine combinestar cp complement compose cp complement const cp complement curry cp complement curryr cp complement fork cp current-input-port current-output-port {cd curses; cp curs_addch curs_addstr; cd ..} {cd curses; cp curs_addch curs_beep; cd ..} {cd curses; cp curs_addch curs_flash; cd ..} {cd curses; cp curs_addch curs_move; cd ..} {cd curses; cp curs_addch curs_mvaddch; cd ..} {cd curses; cp curs_addch curs_mvaddstr; cd ..} {cd curses; cp curs_addch curs_refresh; cd ..} {cd curses; cp curs_addch curs_scroll; cd ..} {cd curses; cp curs_attroff curs_attron; cd ..} {cd curses; cp curs_attroff curs_attrset; cd ..} {cd curses; cp curs_attroff curs_standend; cd ..} {cd curses; cp curs_attroff curs_standout; cd ..} {cd curses; cp curs_cbreak curs_clearok; cd ..} {cd curses; cp curs_cbreak curs_echo; cd ..} {cd curses; cp curs_cbreak curs_get-magic-value; cd ..} {cd curses; cp curs_cbreak curs_idlok; cd ..} {cd curses; cp curs_cbreak curs_keypad; cd ..} {cd curses; cp curs_cbreak curs_nl; cd ..} {cd curses; cp curs_cbreak curs_nocbreak; cd ..} {cd curses; cp curs_cbreak curs_nodelay; cd ..} {cd curses; cp curs_cbreak curs_noecho; cd ..} {cd curses; cp curs_cbreak curs_nonl; cd ..} {cd curses; cp curs_cbreak curs_noraw; cd ..} {cd curses; cp curs_cbreak curs_raw; cd ..} {cd curses; cp curs_cbreak curs_resetty; cd ..} {cd curses; cp curs_cbreak curs_savetty; cd ..} {cd curses; cp curs_cbreak curs_scrollok; cd ..} {cd curses; cp curs_clear curs_clrtobot; cd ..} {cd curses; cp curs_clear curs_clrtoeol; cd ..} {cd curses; cp curs_color-set curs_has-colors; cd ..} {cd curses; cp curs_cursoff curs_curson; cd ..} {cd curses; cp curs_cursoff curs_mvcur; cd ..} {cd curses; cp curs_delch curs_deleteln; cd ..} {cd curses; cp curs_delch curs_insch; cd ..} {cd curses; cp curs_delch curs_insertln; cd ..} {cd curses; cp curs_delch curs_mvdelch; cd ..} {cd curses; cp curs_delch curs_mvinsch; cd ..} {cd curses; cp curs_endwin curs_initscr; cd ..} {cd curses; cp curs_flushinp curs_cols; cd ..} {cd curses; cp curs_flushinp curs_getch; cd ..} {cd curses; cp curs_flushinp curs_getyx; cd ..} {cd curses; cp curs_flushinp curs_inch; cd ..} {cd curses; cp curs_flushinp curs_lines; cd ..} {cd curses; cp curs_flushinp curs_mvgetch; cd ..} {cd curses; cp curs_flushinp curs_mvinch; cd ..} {cd curses; cp curs_flushinp curs_unctrl; cd ..} {cd curses; cp curs_flushinp curs_ungetch; cd ..} cp define-class call-next-method cp define-class class-of cp define-class classp cp define-class define-generic cp define-class define-method cp define-class initialize cp define-class instancep cp define-class make-instance cp define-class slot-ref cp define-class slot-setb cp define-matcher let-matcher cp define-matcher make-matcher cp draw-tree dt cp duplicates dupp cp duplicates dupq cp duplicates dupv cp eq ge cp eq gt cp eq le cp eq lt cp exact-to-inexact inexact-to-exact cp exactp inexactp cp exp log cp exp sin cp exp cos cp exp tan cp exp asin cp exp acos cp exp atan cp exponent mantissa cp floor ceiling cp floor round cp floor truncate cp force delay cp gcd lcm cp get-prop put-prop cp get-prop rem-prop cp get-prop put-propb cp get-prop rem-propb cp help apropos cp htmlify-char htmlify-string cp id false cp id true cp input-portp output-portp cp integer-to-binary-string binary-string-to-integer cp integer-to-binary-string number-of-bits cp iota iotastar cp keyword-value accept-keywords cp loutify-char loutify-string cp macro-expand macro-expand-1 cp make-array array cp make-array arrayp cp make-array array-dimensions cp make-array array-map cp make-array array-rank cp make-array array-ref cp make-array array-setb cp make-array subarray cp make-canvas canvas-draw cp make-canvas canvas-draw-string cp make-canvas canvas-dump cp make-canvas canvas-plot cp make-canvas canvas-plot-line cp make-hash-table alist-to-hash-table cp make-hash-table hash-table-length cp make-hash-table hash-table-ref cp make-hash-table hash-table-removeb cp make-hash-table hash-table-setb cp make-hash-table hash-table-to-alist cp make-rbt rbt-find cp make-rbt rbt-insert cp make-rbt rbt-rebuild cp make-rbt rbt-remove cp make-stream append-streams cp make-stream filter-stream cp make-stream list-to-stream cp make-stream map-stream cp make-stream stream-any cp make-stream stream-eosp cp make-stream stream-extract cp make-stream stream-id cp make-stream stream-iota cp make-stream stream-member cp make-stream stream-next cp make-stream stream-none cp make-stream stream-to-list cp make-stream stream-value cp max min cp memoize define-memoizing cp memq member cp memq memv cp minus slash cp module using cp numberp integerp cp numberp realp {cd sys-unix; cp parse-optionsb display-usage; cd ..} {cd sys-unix; cp parse-optionsb opt-argp; cd ..} {cd sys-unix; cp parse-optionsb opt-char; cd ..} {cd sys-unix; cp parse-optionsb opt-type; cd ..} {cd sys-unix; cp parse-optionsb opt-val; cd ..} {cd sys-unix; cp parse-optionsb option; cd ..} cp permute permutestar cp plus star cp position posp cp position posv cp position posq cp pretty-print pp cp pretty-print pp-file cp pretty-print pp-loop cp pretty-print pp-string cp prolog factb cp prolog new-databaseb cp prolog predicateb cp prolog query cp pushb decb cp pushb incb cp pushb popb cp pushb set-varsb cp pushb swapb cp quasiquote unquote cp quasiquote unquote-splicing cp queue make-queue cp queue queue-emptyp cp queue queueb cp queue unqueueb cp queue unqueuestar cp quotient modulo cp quotient remainder cp r4rs-procedures r4rs-syntax-objects cp r4rs-procedures s9fes-syntax-objects cp r4rs-procedures s9fes-procedures cp r4rs-procedures s9fes-extension-procedures cp r4rs-procedures s9fes-extension-symbols cp random random-state cp re-comp re-match cp re-comp re-subst cp record assert-record-type cp record list-to-record cp record record-copy cp record record-equalp cp record record-ref cp record record-setb cp record record-signature cp record record-to-list cp record record-type-matches cp record recordp cp remove remp cp remove remq cp remove remv cp set-input-portb set-output-portb {cd sys-unix; cp spawn-command spawn-command_fd; cd ..} {cd sys-unix; cp spawn-shell-command spawn-shell-command_fd; cd ..} cp split-url url-anchor cp split-url url-args cp split-url url-host cp split-url url-path cp split-url url-proto cp split-url url-suffix {cd sys-unix; cp standard-error-port call-with-stderr; cd ..} {cd sys-unix; cp standard-error-port with-output-to-stderr; cd ..} cp starstar starepsilonstar cp starstar starextensionsstar cp starstar starlibrary-pathstar cp starstar starhost-systemstar cp starstar starloadingstar cp string-find string-ci-find cp string-find string-ci-find-word cp string-find string-find-word cp string-find-last string-ci-find-last cp string-find-last string-ci-find-last-word cp string-find-last string-find-last-word cp string-last-position string-ci-last-position cp string-last-position string-ci-last-word-position cp string-last-position string-last-word-position cp string-locate string-ci-locate cp string-map string-mapb cp string-position string-ci-position cp string-position string-ci-word-position cp string-position string-word-position cp string-prefixeqp string-prefix-cieqp cp string-scan string-ci-scan cp string-to-list list-to-string cp string-upcase string-downcase cp stringeqp string-cieqp cp stringltp string-cigep cp stringltp string-cigtp cp stringltp string-cilep cp stringltp string-ciltp cp stringltp stringgep cp stringltp stringgtp cp stringltp stringlep {cd sys-unix; cp sys_chmod sys_change_mode; cd ..} {cd sys-unix; cp sys_dup sys_dup2; cd ..} {cd sys-unix; cp sys_getgrnam sys_getgrgid; cd ..} {cd sys-unix; cp sys_getpgid sys_setpgid; cd ..} {cd sys-unix; cp sys_getpwnam sys_getpwuid; cd ..} {cd sys-unix; cp sys_getuid sys_getgid; cd ..} {cd sys-unix; cp sys_group-name sys_group-gid; cd ..} {cd sys-unix; cp sys_inet-listen sys_inet-accept; cd ..} {cd sys-unix; cp sys_kill sys_notify; cd ..} {cd sys-unix; cp sys_make-input-port sys_make-output-port; cd ..} {cd sys-unix; cp sys_open sys_close; cd ..} {cd sys-unix; cp sys_open sys_creat; cd ..} {cd sys-unix; cp sys_read sys_write; cd ..} {cd sys-unix; cp sys_setuid sys_setgid; cd ..} {cd sys-unix; cp sys_stat sys_lstat; cd ..} {cd sys-unix; cp sys_stat-name sys_lstat-atime; cd ..} {cd sys-unix; cp sys_stat-name sys_lstat-ctime; cd ..} {cd sys-unix; cp sys_stat-name sys_lstat-dev; cd ..} {cd sys-unix; cp sys_stat-name sys_lstat-gid; cd ..} {cd sys-unix; cp sys_stat-name sys_lstat-ino; cd ..} {cd sys-unix; cp sys_stat-name sys_lstat-mode; cd ..} {cd sys-unix; cp sys_stat-name sys_lstat-mtime; cd ..} {cd sys-unix; cp sys_stat-name sys_lstat-name; cd ..} {cd sys-unix; cp sys_stat-name sys_lstat-nlink; cd ..} {cd sys-unix; cp sys_stat-name sys_lstat-size; cd ..} {cd sys-unix; cp sys_stat-name sys_lstat-uid; cd ..} {cd sys-unix; cp sys_stat-name sys_stat-atime; cd ..} {cd sys-unix; cp sys_stat-name sys_stat-ctime; cd ..} {cd sys-unix; cp sys_stat-name sys_stat-dev; cd ..} {cd sys-unix; cp sys_stat-name sys_stat-gid; cd ..} {cd sys-unix; cp sys_stat-name sys_stat-ino; cd ..} {cd sys-unix; cp sys_stat-name sys_stat-mode; cd ..} {cd sys-unix; cp sys_stat-name sys_stat-mtime; cd ..} {cd sys-unix; cp sys_stat-name sys_stat-nlink; cd ..} {cd sys-unix; cp sys_stat-name sys_stat-size; cd ..} {cd sys-unix; cp sys_stat-name sys_stat-uid; cd ..} {cd sys-unix; cp sys_stat-regularp sys_lstat-block-devp; cd ..} {cd sys-unix; cp sys_stat-regularp sys_lstat-char-devp; cd ..} {cd sys-unix; cp sys_stat-regularp sys_lstat-directoryp; cd ..} {cd sys-unix; cp sys_stat-regularp sys_lstat-pipep; cd ..} {cd sys-unix; cp sys_stat-regularp sys_lstat-regularp; cd ..} {cd sys-unix; cp sys_stat-regularp sys_lstat-socketp; cd ..} {cd sys-unix; cp sys_stat-regularp sys_lstat-symlinkp; cd ..} {cd sys-unix; cp sys_stat-regularp sys_stat-block-devp; cd ..} {cd sys-unix; cp sys_stat-regularp sys_stat-char-devp; cd ..} {cd sys-unix; cp sys_stat-regularp sys_stat-directoryp; cd ..} {cd sys-unix; cp sys_stat-regularp sys_stat-pipep; cd ..} {cd sys-unix; cp sys_stat-regularp sys_stat-socketp; cd ..} {cd sys-unix; cp sys_user-name sys_user-gecos; cd ..} {cd sys-unix; cp sys_user-name sys_user-gid; cd ..} {cd sys-unix; cp sys_user-name sys_user-home; cd ..} {cd sys-unix; cp sys_user-name sys_user-shell; cd ..} {cd sys-unix; cp sys_user-name sys_user-uid; cd ..} {cd sys-unix; cp sys_usleep sys_sleep; cd ..} {cd sys-unix; cp sys_wait sys_waitpid; cd ..} cp t-sort t-sort-net cp tagbody go cp thread-create thread-exit cp thread-create thread-start cp thread-create thread-yield cp time-add time-subtract cp time-add time-difference cp time-add time-beforep cp time-add time-afterp {cd sys-unix; cp time timestar; cd ..} cp type-case type-of cp vector-to-list list-to-vector cp vector-map vector-mapb cp when unless cp while until cp with-input-from-file with-output-to-file cp write-to-string display-to-string cp zerop evenp cp zerop negativep cp zerop oddp cp zerop positivep s9/prog/c2html1.scm000755 001751 001751 00000003344 12043755507 013765 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f ; c2html -- print C code to HTML ; By Nils M Holm, 2009-2012 ; Placed in the Public Domain ; ; Usage: c2html [-dL] [file ...] ; ; Render C code contained in the given file. When no file ; is given, render stdin. Write output to stdout. ; ; Options: ; ; -d write a full HTML document (default: PRE block only) ; -L emit Lout output instead of HTML ; ; The CSS2 style sheet "ccode.css" contains the default style for ; syntax highlighting. ; ; NOTE: This program handles only a subset of C89 correctly. ; Caveat utilitor! (load-from-library "c2html.scm") (load-from-library "parse-optionsb.scm") (define show-help (option #\h #f)) (define full-html (option #\d #f)) (define lout-mode (option #\L #f)) (define options `(,full-html ,lout-mode ,show-help)) (define (usage) (display "Usage: c2html [-dL] [file ...]") (newline)) (let ((files (parse-options! (sys:command-line) options usage))) (cond ((opt-val show-help) (display-usage `("" ,usage "" "Render C code in HTML" "" "-d write full HTML document (default: PRE block only)" "-L emit Lout output instead of HTML" "")) (sys:exit 0)) ((null? files) (c2html 'full-html: (opt-val full-html) 'lout-mode: (opt-val lout-mode))) (else (for-each (lambda (file) (with-input-from-file file (lambda () (c2html 'full-html: (opt-val full-html) 'lout-mode: (opt-val lout-mode))))) files)))) s9/prog/s9resolve.scm000755 001751 001751 00000021034 12061606674 014442 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f ; s9resolve -- resolve S9fES library dependencies ; By Nils M Holm, 2010 ; Placed in the Public Domain ; ; Usage: s9resolve [-dsv] [file] ; ; This program replaces LOAD-FROM-LIBRARY forms in S9fES with the ; code contained in the referenced libraries, thereby turning ; S9fES code into more portable Scheme code. ; ; Options: ; ; -d dependency check mode ; -s strip initial comment blocks from included programs ; -v verbose mode (load-from-library "symbols.scm") (load-from-library "flatten.scm") (load-from-library "string-split.scm") (load-from-library "displaystar.scm") (load-from-library "read-line.scm") (load-from-library "hash-table.scm") (load-from-library "programp.scm") (load-from-library "basename.scm") (load-from-library "parse-optionsb.scm") (define *depth* 0) (define dep-check-mode (option #\d #f)) (define skip-comments (option #\s #f)) (define verbose (option #\v #f)) (define show-help (option #\h #f)) (define options `(,dep-check-mode ,skip-comments ,verbose ,show-help)) (define *Pass-1* #t) (define *Filename* #t) (define *Definitions* (make-hash-table 'test eq?)) (define *Undefined* (make-hash-table 'test eq?)) (define *Libraries* (make-hash-table)) (define (resolve) (let loop ((line (read-line))) (cond ((eof-object? line)) ((let* ((tokens (string-split #\space line)) (first (car tokens))) (and (= (string-length first) 18) (string-ci=? "(load-from-library" first))) ;) balance (let* ((tokens (string-split #\space line)) (lib (string-split #\" (cadr tokens))) (lib (if (or (null? lib) (null? (cdr lib))) (error "malformed load-from-library" line) (cadr lib)))) (cond ((or (locate-file lib) (locate-file (string-append lib ".scm"))) => (lambda (file) (newline) (display "; ----- included file: ") (display (basename file)) (display " -----") (newline) (newline) (resolve-file file) (display "; ----- end of file: ") (display (basename file)) (display " -----") (newline) (loop (read-line)))) (else (error "failed to resolve" lib))))) (else (display line) (newline) (loop (read-line)))))) (define (resolve-file file) (set! *depth* (+ 1 *depth*)) (with-input-from-file file (lambda () (if (opt-val skip-comments) (let loop ((line (read-line))) (if (and (not (eof-object? line)) (not (string=? "" line)) (char=? #\; (string-ref line 0))) (loop (read-line))))) (resolve))) (set! *depth* (- *depth* 1)) (newline)) (define (add-definition name) (hash-table-set! *Definitions* name #t)) (define (defined? name) (or *Pass-1* (and (hash-table-ref *Definitions* name) #t))) (define (seen-before? name) (and (hash-table-ref *Undefined* name) #t)) (define (seen-before! name) (hash-table-set! *Undefined* name #t)) (define (check-deps form) (cond ((and (list? form) (not (null? form))) (case (car form) ((and begin if or) (for-each check-deps (cdr form))) ((apply) (check-deps (cdr form))) ((case) (check-deps (cadr form)) (for-each (lambda (x) (for-each check-deps (cdr x))) (cddr form))) ((cond) (for-each (lambda (x) (for-each check-deps (cdr x))) (cdr form))) ((define define-syntax) (if (pair? (cadr form)) (for-each add-definition (flatten (cadr form))) (add-definition (cadr form))) (for-each check-deps (cddr form))) ((delay) (check-deps (cadr form))) ((do) (for-each (lambda (x) (add-definition (car x)) (for-each check-deps (cdr x))) (cadr form)) (for-each check-deps (cddr form))) ((lambda) (for-each add-definition (flatten (cadr form))) (check-deps (cddr form))) ((let) (if (symbol? (cadr form)) (add-definition (cadr form))) (for-each (lambda (x) (add-definition (car x)) (check-deps (cadr x))) (if (symbol? (cadr form)) (caddr form) (cadr form))) (check-deps (if (symbol? (cadr form)) (cdddr form) (cddr form)))) ((let* letrec) (for-each (lambda (x) (add-definition (car x)) (check-deps (cadr x))) (cadr form)) (check-deps (cddr form))) ((quote quasiquote) #t) ((set!) (check-deps (cadr form))) ((syntax-rules) #t) (else (if (pair? (car form)) (check-deps (car form)) (if (and (not (defined? (car form))) (not (seen-before? (car form)))) (begin (seen-before! (car form)) (display* *Filename* ": " (car form) #\newline)))) (for-each check-deps (cdr form))))))) (define (dep-check) (let loop ((form (read))) (cond ((eof-object? form)) ((and (pair? form) (program? form)) (if (eq? 'load-from-library (car form)) (dep-check-lib (cadr form))) (check-deps form) (loop (read))) (else (loop (read)))))) (define (dep-check-file file) (let ((old-file *Filename*)) (set! *Filename* file) (if (opt-val verbose) (display* "; File: " *Filename* #\newline)) (set! *Pass-1* #t) (with-input-from-file file dep-check) (set! *Pass-1* #f) (with-input-from-file file dep-check) (set! *Pass-1* #t) (set! *Filename* old-file))) (define (dep-check-lib lib) (if (not (hash-table-ref *Libraries* lib)) (let ((path (locate-file lib))) (hash-table-set! *Libraries* lib #t) (if (not lib) (error "library not found" lib) (dep-check-file path))))) (define (usage) (display "Usage: s9resolve [-ds] [file ...]") (newline)) (for-each (lambda (x) (hash-table-set! *Definitions* x #t)) (append (r4rs-syntax-objects) (r4rs-procedures) (s9fes-syntax-objects) (s9fes-procedures) (s9fes-extension-procedures) (s9fes-extension-symbols))) (let ((files (parse-options! (sys:command-line) options usage))) (cond ((opt-val show-help) (display-usage `("" ,usage "" "Resolve or check S9 library dependencies" "" "-d dependency check mode" "-s strip initial comment blocks from included programs" "-v verbose mode" "")) (sys:exit 0)) ((null? files) (if (opt-val dep-check-mode) (error "-d requires a file") (resolve))) ((opt-val dep-check-mode) (for-each dep-check-file files)) (else (for-each (lambda (file) (newline) (with-input-from-file file resolve)) files)))) s9/prog/soccat.scm000755 001751 001751 00000005011 11477627001 013755 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f ; soccat -- connect to remote hosts ; By Nils M Holm, 2010 ; Placed in the Public Domain ; ; Usage: soccat [-i] host port/service ; ; Read a request from default input and send it to the specific ; remote host. Simultaneously pass input from the remote host to ; the default output. In interactive mode reconnect automatically ; when the remote side breaks the connection. ; ; Options: ; ; -i interactive mode (reconnect automatically) (load-from-library "read-line.scm") (load-from-library "displaystar.scm") (load-from-library "flush-output-port.scm") (load-from-library "parse-optionsb.scm") (define (soccat reconnect host port) (let* ((s (sys:inet-connect host port)) (in (sys:make-input-port s)) (out (sys:make-output-port s))) (let ((pid (sys:fork))) (if (not (zero? pid)) (let out-loop () (if (sys:waitpid pid) (begin (close-input-port in) (close-output-port out) (if reconnect (soccat reconnect host port) (sys:exit)))) (if (sys:select '(0 100000) '(0) '()) (let ((line (read-line))) (if (eof-object? line) (begin (sys:wait) (sys:exit)) (begin (display* out line #\newline) (flush-output-port out))))) (out-loop)) (let in-loop ((line (read-line in))) (if (eof-object? line) (sys:exit) (begin (display* line #\newline) (flush-output-port) (in-loop (read-line in))))))))) (define show-help (option #\h #f)) (define interactive-mode (option #\i #f)) (define options `(,show-help ,interactive-mode)) (define (usage) (display* "Usage: soccat [-i] host port" #\newline)) (let ((args (parse-options! (sys:command-line) options usage))) (if (opt-val show-help) (begin (display-usage `("" ,usage "" "Connect to remote hosts" "" "-i interactive mode (reconnect automatically)" "")) (sys:exit))) (if (not (= 2 (length args))) (begin (usage) (sys:exit 1))) (if (opt-val interactive-mode) (display* "Interactive mode, send INTR to exit" #\newline)) (apply soccat (opt-val interactive-mode) args)) s9/prog/htmlify.scm000755 001751 001751 00000004246 11477627001 014166 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f ; htmlify -- convert plain text files to HTML ; by Nils M Holm, 2010 ; Placed in the Public Domain ; ; Usage: htmlify -t [file ...] (load-from-library "parse-optionsb.scm") (define (emit-newlines n) (if (not (zero? n)) (begin (newline) (emit-newlines (- n 1))))) (define (htmlify trim) (let loop ((c (read-char)) (nnl 0) (lead #t)) (if (eof-object? c) (if trim (newline) (emit-newlines nnl)) (begin (if (char=? (integer->char 10) c) (loop (read-char) (+ 1 nnl) lead) (begin (if (or (not trim) (not lead)) (emit-newlines nnl)) (cond ((char=? #\< c) (display "<") (loop (read-char) 0 #f)) ((char=? #\> c) (display ">") (loop (read-char) 0 #f)) ((char=? #\& c) (display "&") (loop (read-char) 0 #f)) (else (write-char c) (loop (read-char) 0 #f))))))))) (define trim-lead (option #\t #f)) (define show-help (option #\h #f)) (define options `(,trim-lead ,show-help)) (define (usage) (display "Usage: htmlify [-t] [file ...]") (newline)) (let ((files (parse-options! (sys:command-line) options usage))) (if (opt-val show-help) (begin (display-usage `("" ,usage "" "Convert plain text files to HTML" "" "-t trim leading and trailing blank lines" "")) (sys:exit 0))) (if (null? files) (htmlify (opt-val trim-lead)) (for-each (lambda (file) (with-input-from-file file (lambda () (htmlify (opt-val trim-lead))))) files))) s9/prog/dupes.scm000755 001751 001751 00000005340 11477627002 013627 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f ; dupes -- find duplicate file names ; by Nils M Holm, 2010 ; Placed in the Public Domain ; ; Usage: dupes [directory] (load-from-library "hof.scm") (load-from-library "hash-table.scm") (load-from-library "string-split.scm") (load-from-library "basename.scm") (load-from-library "parse-optionsb.scm") (load-from-library "displaystar.scm") (define readable-output (option #\r #f)) (define show-help (option #\h #f)) (define options `(,readable-output ,show-help)) (define (usage) (display "Usage: dupes [-r] [file ...]") (newline)) (let* ((files (parse-options! (sys:command-line) options usage)) (files (if (null? files) '(".") files)) (found (make-hash-table)) (first #t) (list-dupes (lambda (readable) (for-each (lambda (set) (if (> (length set) 2) (begin (if first (set! first #f) (if readable (newline))) (if readable (display* (car set) ":") (display (car set))) (for-each (lambda (loc) (if readable (display* #\newline loc) (display* #\space loc))) (cdr set)) (newline)))) (hash-table->alist found))))) (if (opt-val show-help) (begin (display-usage `("" ,usage "" "Find duplicate directory entries" "" "-r print human-readable output" "")) (sys:exit 0))) (let loop ((files files)) (let* ((path (if (null? files) "ignore" (car files))) (name (basename path))) (cond ((null? files) (list-dupes (opt-val readable-output))) ((sys:lstat-directory? path) (loop (append (map (curry string-append path "/") (sys:readdir path)) (cdr files)))) ((sys:lstat-symlink? path) (loop (cdr files))) ((hash-table-ref found name) => (lambda (refs) (hash-table-set! found name (cons path (car refs))) (loop (cdr files)))) (else (hash-table-set! found name (list path)) (loop (cdr files))))))) s9/prog/s9help.scm000755 001751 001751 00000005251 12550701546 013713 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f ; s9help -- find and display S9fES help pages ; by Nils M Holm, 2010,2015 ; Placed in the Public Domain ; ; Usage: s9help [-als] topic ... ; ; Options: ; ; -a find any match (default: full words only) ; -l long results (including context) ; -s search help pages (default: display) (load-from-library "find-help.scm") (load-from-library "name-to-file-name.scm") (load-from-library "read-line.scm") (load-from-library "parse-optionsb.scm") (define search (option #\s #f)) (define long (option #\l #f)) (define any-match (option #\a #f)) (define show-help (option #\h #f)) (define options `(,search ,long ,any-match ,show-help)) (define (usage) (display "Usage: s9help [-als] topic ...") (newline)) (define (display-help topic) (let loop ((exts (cons "." (map symbol->string *extensions*)))) (if (null? exts) (begin (display* "s9: " topic ": help file not found" #\newline) (sys:exit 1)) (let ((path (string-append (find-help-path) "/" (car exts) "/" (name->file-name topic)))) (if (not (file-exists? path)) (loop (cdr exts)) (with-input-from-file path (lambda () (newline) (let print ((line (read-line))) (if (eof-object? line) (newline) (begin (display line) (newline) (print (read-line)))))))))))) (let ((topic* (parse-options! (sys:command-line) options usage))) (if (opt-val show-help) (begin (display-usage `("" ,usage "" "Find and display S9fES help pages" "" "-a find any match (default: full words only)" "-l long results (including context)" "-s search help pages (default: display)" "")) (sys:exit 0))) (let ((topic* (if (null? topic*) (begin (usage) (sys:exit 1)) topic*))) (for-each (lambda (topic) (if (opt-val search) (find-help topic (string-append "p" (if (opt-val long) "l" "") (if (opt-val any-match) "a" ""))) (display-help topic))) topic*))) s9/prog/scm2html1.scm000755 001751 001751 00000005715 12030054735 014320 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f ; scm2html -- print Scheme code to HTML ; By Nils M Holm, 2009,2010 ; Placed in the Public Domain ; ; Usage: scm2html [-9dsx] [file ...] ; ; Render Scheme code contained in the given file. When no file ; is given render stdin. Write output to stdout. ; ; Options: ; ; -9 highlight S9fES (non-R4RS) procedures ; -d write a full HTML document (default: PRE block only) ; -s enable CSS-based syntax highlighting ; -x highlight S9fES extension procedures ; -L emit Lout output instead of HTML ; ; The CSS2 style sheet "scheme.css" contains the default style for ; syntax and expression highlighting. ; ; NOTE: This program handles only a subset of R4RS Scheme correctly. ; Caveat utilitor! (load-from-library "scm2html.scm") (load-from-library "parse-optionsb.scm") (define show-help (option #\h #f)) (define show-matches (option #\s #f)) (define full-html (option #\d #f)) (define mark-s9-procs (option #\9 #f)) (define tilde-quotes (option #\t #f)) (define mark-s9-extns (option #\x #f)) (define lout-mode (option #\L #f)) (define options `(,show-matches ,full-html ,mark-s9-procs ,tilde-quotes ,mark-s9-extns ,show-help ,lout-mode)) (define (usage) (display "Usage: scm2html [-9dstxL] [file ...]") (newline)) (let ((files (parse-options! (sys:command-line) options usage))) (cond ((opt-val show-help) (display-usage `("" ,usage "" "Render Scheme code in HTML" "" "-9 highlight S9fES (non-R4RS) procedures" "-d write full HTML document (default: PRE block only)" "-s enable CSS-based syntax highlighting" "-t enable invisible tilde quotation" "-x highlight S9fES extension procedures" "-L emit Lout output instead of HTML" "")) (sys:exit 0)) ((null? files) (scm2html 'full-html: (opt-val full-html) 'show-matches: (opt-val show-matches) 'mark-s9-procs: (opt-val mark-s9-procs) 'tilde-quotes: (opt-val tilde-quotes) 'mark-s9-extns: (opt-val mark-s9-extns) 'lout-mode: (opt-val lout-mode))) (else (for-each (lambda (file) (with-input-from-file file (lambda () (scm2html 'full-html: (opt-val full-html) 'show-matches: (opt-val show-matches) 'mark-s9-procs: (opt-val mark-s9-procs) 'tilde-quotes: (opt-val tilde-quotes) 'mark-s9-extns: (opt-val mark-s9-extns) 'lout-mode: (opt-val lout-mode))))) files)))) s9/prog/advgen.txt000644 001751 001751 00000045704 12033014135 013777 0ustar00nmhnmh000000 000000 ================================================================ ADVGEN -- An HTML Text Adventure Generator By Nils M Holm, 2010,2012 ================================================================ The ADVGEN program reads a set of "vertexes" from its input and writes a set of HTML files to the output. Each HTML file contains some text describing the vertex and a set of "actions" that lead to other files. All state of the game is kept in the HTML files, so absolutely no server-side support is necessary. All that is needed on the client side is an HTML browser. The ADVGEN input is a sequence of vertexes: := ... Vertexes are specified in S-Expression form (LISP syntax): := ( ) | ( ...) The "vertex-id" is just a LISP symbol name that identifies this vertex. The "description" part is what the player will see in the page that is generated from this vertex. It may have one of the following forms: := ("text" "more text" ...) | (copy-from ) When a description has the special form (copy-from ), the description will be copied from the given vertex, allowing the user to keep repetitive descriptions in a single place. The "modifier" is where all the action takes place. First its formal definition: := ( ("description" ...) "link text" ) | ( ("description" ...) ("prefix" "link text" "suffix") ) Each modifier consists of a "condition," more descriptive text, the text for the link that activates the modifier, and an "action" that will be carried out when the link is being followed. The description contained in the modifier will only be displayed when its condition is true. When the link text is a list of three strings, only the middle part of that string will be included in the resulting HTML anchor, e.g.: ("$ " "cat foo" "[enter]") will render $ cat foo [enter] A "condition" is simply a list of symbol names, which are called "properties" here, or negated symbol names: := ( ...) | () := | (not ) When a condition consists merely of the empty list (), it is trivially true. When it consists of a property, it is true when the property exists and otherwise false. When a condition consists of a "clause" of the form (not ) then the condition is true when the property does not exist. When multiple clauses are given, the condition is true if all of them are true. E.g., (matches (not light)) is true when the "matches" property exists but the "light" property does not exist. An "action", finally, is an instruction to the ADVGEN compiler. Instructions tell the compiler to add or remove properties or walk to a different vertex. Formally, an action looks like this: := (go ["message"]) | (add ["message"]) | (rem ["message"]) | (add/go ["message"]) | (rem/go ["message"]) | (go/cut ... ) | (go/sel ... ) | (nop ... ["message"]) GO tells the compiler to generate a link to the HTML file representing the given vertex combined with the current state of the game. The link is inserted in the page currently being generated and then the compiler advances to the given vertex and generates the file referred to by the link. The state of the game is simply a list of properties that are currently in effect. ADD also generates a link, but stays in the current vertex. However, it changes the state of the game by adding a property, so it also generates a new HTML file. REM removes a property and stays in the same vertex. ADD/GO adds a property and moves to a different vertex at the same time. REM/GO removes a property and moves to a different vertex at the same time. GO/CUT moves to a different vertex and removes all properties specified as its arguments. GO/SEL moves to a different vertex and selects all properties specified in its arguments (removing all others). NOP does nothing. It accepts any combination of arguments. Most of the actions also accept a "message" argument, which must be last in the list. When this argument is specified, following a link generated by ADVGEN will lead to a file containing just this message and another link which leads to the final destination of the action. It is typically used to inject short explanatory messages. For the sake of completeness here follow the formal definitions of the various identifiers used above: := := := [a-z0-9:\-]+ Note that vertex-id's are used as headings in generated HTML files, where minus signs ("-") are replaced with blanks and all characters following a colon (":") are clipped off. So, for instance "floor-1:dark" becomes "Floor 1". (Yes, the first character is being capitalized.) These special characters can be used to make the headings more pleasant to the eye and hide state information at the same time. ================================================================ SAMPLE GAME ================================================================ Here is a very short sample game: ---------------------------------------------------------------- (room ("This is a sample room.") (((not light)) ("It's pitch-dark!") "Turn on light" (add light)) ((light) ("It's too bright!") "Turn off light" (rem light))) ---------------------------------------------------------------- Compiling it will generate two HTMl files representing the state and vertex combinations (room) (room light) The resulting HTML files will look like this (formatted for clarity): ---------------------------------------------------------------- ced21dfa.html: 6b3b490b.html: Room Room

Room

Room

This is a sample room.

This is a sample room.

It's pitch-dark!

It's too bright!

Turn off light
---------------------------------------------------------------- When rendered the pages will look like this: +------------------------+ +------------------------+ | Room | | Room | | | | | | This is a sample room. | | This is a sample room. | | It's pitch-dark! | | It's too bright! | | | | | | Turn on light | | Turn off light | | ------------- | | -------------- | +------------------------+ +------------------------+ Note that a separate HTML file is generated for each combination of vertex and properties, so the number of generated files is usually larger -- sometimes *much* larger -- than the number of vertexes in the game description. When adding another room to the initial example, the number of states will increase: ---------------------------------------------------------------- (room-1 ("This is a sample room.") (((not light)) ("It's pitch-dark!") "Turn on light" (add light)) ((light) ("It's too bright!") "Turn off light" (rem light)) (() ; ("There is another room nearby.") ; new "Go to other room" ; (go room-2))) ; ; (room-2 ; ("This is a another sample room.") ; (() ; ("Nothing to see here.") ; "Go back" ; (go room-1))) ; ---------------------------------------------------------------- When compiling this game description, four HTML files representing the following states will be generated: (room-1) (room-1 light) (room-2) (room-2 light) The property "light" is being propagated to the other room. This way the game "remembers" that you turned on the light in ROOM-1. When you later return to it from ROOM-2, you will still find it switched on: ---------------------------------------------------------------- +---------+ +---------+ | room-1 | ---- GO ---> | room-2 | | () | <--- GO ---- | () | +---------+ +---------+ | /|\ | | ADD REM | | \|/ | +---------+ +---------+ | room-1 | ---- GO ---> | room-2 | | (light) | <--- GO ---- | (light) | +---------+ +---------+ ---------------------------------------------------------------- Because the names of the states are hidden behind colons in the vertex identifiers, the player cannot infer the current state of the game. Not even the file names give away hints, because they are formed by hexa-decimal representations of string digests of the state tags associated with the files. The entire state of the game is encoded in the graph structure formed by the links. The compiler will never generate state files that are not needed. Have a look at the following example: ---------------------------------------------------------------- (room-1 ("This is a sample room.") (((not light)) ("It's pitch-dark!") "Turn on light" (add light)) ((light) ("It's too bright!") "Turn off light" (rem light)) ((light) ; ("Aha! There is another room nearby!") ; changed "Go to other room" ; (go room-2))) ; ; room-2 as above ---------------------------------------------------------------- In this example, the other room can only be seen when the light has been turned on, and the link leading to the second rooms is only activated when the light is on. Consequently, the other room cannot be entered with the light off, so the compiler cuts that branch off. Only three states will be generated: ---------------------------------------------------------------- +---------+ | room-1 | | () | +---------+ | /|\ | | ADD REM | | \|/ | +---------+ +---------+ | room-1 | ---- GO ---> | room-2 | | (light) | <--- GO ---- | (light) | +---------+ +---------+ ---------------------------------------------------------------- Of course, keeping all state information in the game graph can lead to an exponential growth of state space in games that are a bit more complex. In the worst case, the number of total states in a game would be (expt n_vertexes n_properties) So a game with 10 properties and 25 vertexes could generate 95,367,431,640,625 files. Yes, that's 95 *trillion* files. This is obviously not practicable. And this is the point where the GO/CUT operator comes into play. It is used to "cut off" chunks of the game graph, thereby reducing the number of generated states and files. What it does is to remove the given properties from the game state, so in principle (go/cut room-2 light) would be equal to (rem/go light room-2) However, GO/CUT can be used to cut off any number of properties, while REM/GO can only remove one at a time. Then again GO/CUT cannot inject explanatory messages, which REM/GO can. It is up to you to choose the right tool for the task. Using (GO/CUT ROOM-2 LIGHT) instead of (GO ROOM-2) in the original example (with the second room visible all the time) would result in the following game tree: ---------------------------------------------------------------- +---------+ | room-1 | --------- GO ---------+ | () | <-----------------+ | +---------+ | | | /|\ | | | | GO | ADD REM | | | | | | \|/ | | \|/ +---------+ +---------+ | room-1 | --- GO/CUT --> | room-2 | | (light) | | () | +---------+ +---------+ ---------------------------------------------------------------- Of course in this game the light would have turned off automagically each time you return to ROOM-1. So it is a good idea to place the GO/CUT operator in one-way actions, as in the following example: ---------------------------------------------------------------- (room-1 ("This is a sample room.") (((not light)) ("It's pitch-dark!") "Turn on light" (add light)) (() ("There is another room nearby.") "Go to other room" (rem/go light room-2 "The door locks behind you."))) (room-2 ("This is a another sample room." "There is a locked door here.")) ---------------------------------------------------------------- In this case it does not matter whether the light is on or off in ROOM-1, because the player cannot return to it anyway. Of course, they could use the "back" button of their browser to return there, but in this case the history function of the browser will take care of restoring the proper state. The graph of this sample game will look like this: ---------------------------------------------------------------- . . . . . . . . . . . . . . . . . . . +---------+ . . . . | room-1 | ------ GO/CUT ------+ . . | () | . . | . . +---------+ . . | . . | /|\ . . | . . | | . . | . . ADD REM . . | . . | | . . | . . \|/ | . . \|/ . . +---------+ . . +---------+ . . | room-1 | --- GO/CUT --> | room-2 | . . | (light) | . . | () | . . +---------+ . . +---------+ . . . . . . . . . . . . . . . . . . . level 1 level 2 ---------------------------------------------------------------- When designing large games it is a good idea to create "levels" (whether or not they are visible to the user does not matter) that have separate state spaces. Of course it may be desirable to carry *some* state from level to level, but keeping the state space of the sub-levels manageable is certainly an important thing to keep in mind. ================================================================ NAVIGATION GRID ================================================================ When any of the modifiers of a vertex has a link text that consists of one of the strings "N" "E" "S" "W" "NE" "SE" "SW" "NW" then ADVGEN will generate a navigation grid of the form +------------+ | NW N NE | | W E | | SW S SE | +------------+ and display it below the other actions that a player may select. Only the directions that are actually used will be linked in the grid. Of course, when using one of the direction abbreviations, all available directions should be abbreviated so that they will all show up in the grid. That's it. Have fun creating your own games! s9/prog/advgen.scm000755 001751 001751 00000055704 12051122602 013745 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f ; advgen -- generate HTML text adventures ; by Nils M Holm, 2010,2012 ; Placed in the Public Domain ; ; Usage: advgen [too many options] [file] ; ; Sample adventure: ; ; (room ; ("This is a sample room.") ; (((not light)) ; ("It's pitch-dark!") ; "Turn on light" ; (add light)) ; ((light) ; ("It's too bright!") ; "Turn off light" ; (rem light))) (load-from-library "string-split.scm") (load-from-library "string-translate.scm") (load-from-library "for-all.scm") (load-from-library "remove.scm") (load-from-library "basename.scm") (load-from-library "displaystar.scm") (load-from-library "append-to-output-file.scm") (load-from-library "string-digest.scm") (load-from-library "write-to-string.scm") (load-from-library "hash-table.scm") (load-from-library "parse-optionsb.scm") (define bare-html (option #\b #f)) (define debug-info (option #\d #f)) (define dry-run (option #\n #f)) (define dumpdir (option #\o 'string)) (define hash-length (option #\H 'integer)) (define intro-text (option #\i 'string)) (define path-length (option #\P 'string)) (define page-epilog (option #\e 'string)) (define remove-old (option #\r #f)) (define page-prolog (option #\p 'string)) (define show-help (option #\h #f)) (define squeeze-nl (option #\s #f)) (define state-comments (option #\c #f)) (define style-sheet (option #\y 'string)) (define title-text (option #\t 'string)) (define verbose (option #\v 'counter)) (define options `(,show-help ,bare-html ,debug-info ,dry-run ,dumpdir ,hash-length ,intro-text ,page-epilog ,path-length ,page-prolog ,remove-old ,squeeze-nl ,state-comments ,style-sheet ,title-text ,verbose)) (define *dumpdir* "advdump") (define *dest-node* #f) (define *min-depth* #f) (define *hash-length* 8) (define *visited* (make-hash-table)) (define *base* #t) (define vertex-id car) (define vertex-desc cadr) (define vertex-cond* cddr) (define mod-cond car) (define mod-desc cadr) (define mod-link caddr) (define mod-action cadddr) (define (valid-action? a) (and (list? a) (not (null? a)) (or (and (memq (car a) '(go add rem)) (<= 2 (length a) 3) (symbol? (cadr a)) (or (null? (cddr a)) (string? (caddr a)))) (and (memq (car a) '(nop)) (<= 1 (length a))) (and (memq (car a) '(add/go rem/go)) (<= 3 (length a) 4) (symbol? (cadr a)) (symbol? (caddr a)) (or (null? (cdddr a)) (string? (cadddr a)))) (and (memq (car a) '(go/cut go/sel)) (>= (length a) 2) (for-all symbol? (cdr a)))))) (define (valid-clause? x) (or (symbol? x) (and (list? x) (= 2 (length x)) (eq? 'not (car x)) (symbol? (cadr x))))) (define (valid-description? x) (and (list? x) (or (for-all string? x) (and (= 2 (length x)) (eq? 'copy-from (car x)) (symbol? (cadr x)))))) (define (list-of-string? x) (and (list? x) (for-all string? x))) (define (valid-link-text? x) (or (string? x) (and (list-of-string? x) (= 3 (length x))))) (define (adv-error v-id msg . obj) (display "advgen: ") (if v-id (display* "vertex " v-id ": ")) (display* "error: " msg) (if (not (null? obj)) (display* ": " (car obj))) (newline) (sys:exit 1)) ; An adventure description is a sequence of vertexes ; of the following form: ; ; vertex := ( ; ("description" ; ...) ; ((|(not ) ...) ; ("description" ...) ; "action description" ; ; ...) ; ; := (go ["message"]) ; | (add ["message"]) ; | (add/go ["message"]) ; | (rem ["message"]) ; | (rem/go ["message"]) ; | (go/cut ... ) ; | (go/sel ... ) ; | (nop [] [] ["message"]) ; ; := [a-z0-9:\-]+ (define (read-description) (let ((vertexes (make-hash-table)) (base #f)) (let loop ((obj (read))) (cond ((eof-object? obj) (list base vertexes)) ((not (list? obj)) (adv-error #f "expected a vertex, got" obj)) ((< (length obj) 2) (adv-error #f "missing members in vertex" obj)) ((not (symbol? (vertex-id obj))) (adv-error #f "malformed vertex ID" (vertex-id obj))) ((not (valid-description? (vertex-desc obj))) (adv-error (vertex-id obj) "malformed description in vertex" (vertex-desc obj))) ((let cloop ((c* (vertex-cond* obj))) (and (not (null? c*)) (let ((c (car c*))) (if (not (= 4 (length c))) (adv-error (vertex-id obj) "missing members in modifier" c)) (if (or (not (list? (mod-cond c))) (not (for-all valid-clause? (mod-cond c)))) (adv-error (vertex-id obj) "malformed condition in modifier" (mod-cond c))) (if (not (valid-description? (mod-desc c))) (adv-error (vertex-id obj) "malformed description in modifier" (mod-desc c))) (if (not (valid-link-text? (mod-link c))) (adv-error (vertex-id obj) "malformed link text in modifier" (mod-link c))) (if (not (valid-action? (mod-action c))) (adv-error (vertex-id obj) "malformed action in modifier" (mod-action c))) (cloop (cdr c*)))))) (else (if (hash-table-ref vertexes (vertex-id obj)) (adv-error #f "duplicate vertex ID" (vertex-id obj))) (hash-table-set! vertexes (vertex-id obj) obj) (if (not base) (set! base (vertex-id obj))) (loop (read))))))) (define (append-map p . x) (apply append (apply map p x))) (define (make-path id) (string-append *dumpdir* "/" id ".html")) (define *vertex-counter* 0) (define unique (let ((h (make-hash-table))) (lambda (seed len) (let ((v (string-digest (write-to-string seed) (* 4 len)))) (set! *vertex-counter* (+ 1 *vertex-counter*)) (let loop ((v v)) (if (hash-table-ref h v) (loop (+ 1 v)) (let ((s (number->string v 16))) (hash-table-set! h v #t) (if (>= (string-length s) len) (substring s 0 len) (string-append (make-string (- len (string-length s)) #\0) s))))))))) (define (emit* . args) (if (not (opt-val dry-run)) (if (opt-val squeeze-nl) (apply display* (remv #\newline args)) (apply display* args)))) (define (call-with-dummy-file file thunk) (thunk #f)) (define (copy-to out) (if (not (opt-val dry-run)) (let loop ((c (read-char))) (if (not (eof-object? c)) (begin (write-char c out) (loop (read-char))))))) (define (html-prelude out title) (if (not (opt-val bare-html)) (emit* out "" #\newline "" #\newline "" title "" #\newline (cond ((opt-val style-sheet) => (lambda (name) (string-append "" (string #\newline)))) (else "")) "" #\newline "" #\newline)) (cond ((opt-val page-prolog) => (lambda (path) (with-input-from-file path (lambda () (copy-to out)))))) (cond ((opt-val title-text) => (lambda (text) (emit* out "

" text "

" #\newline (if (opt-val page-prolog) "" "
") #\newline ))))) (define (html-postlude out) (cond ((opt-val page-epilog) => (lambda (path) (with-input-from-file path (lambda () (copy-to out)))))) (if (not (opt-val bare-html)) (emit* out "" #\newline "" #\newline))) (define (make-interim-page msg dest) (let ((i-vertex (unique msg *hash-length*))) (if (and (opt-val verbose) (> (opt-val verbose) 1)) (display* "state: interim" #\newline)) (if (not (opt-val dry-run)) (with-output-to-file (make-path i-vertex) (lambda () (html-prelude (current-output-port) "Info") (emit* "

" msg "

" #\newline "

" "Continue

" #\newline) (html-postlude (current-output-port))))) i-vertex)) (define (make-heading sym) (let* ((s (symbol->string sym)) (s (car (string-split #\: s))) (l (string->list s)) (l (cons (char-upcase (car l)) (cdr l)))) (string-translate (list->string l) "-" " "))) (define (last x) (car (reverse x))) (define (all-but-last x) (reverse! (cdr (reverse x)))) (define (emit-desc out desc) (for-each (lambda (x) (emit* out x #\newline)) desc)) (define (emit-mod-desc* out c*) (cond ((not (null? c*)) (for-each (lambda (x) (if (not (null? (mod-desc x))) (emit-desc out (mod-desc x)))) c*)))) (define (cycle prop v-id) (adv-error v-id "cycling through property" prop)) (define (cut-props props state) (if (null? props) state (cut-props (cdr props) (remq (car props) state)))) (define (retain-props props state) (let ((cut (cut-props props state))) (cut-props cut state))) (define (make-nav-grid out dir*) (letrec ((find-dir (lambda (d d*) (cond ((null? d*) #f) ((string=? d (mod-link (cadar d*))) (caar d*)) (else (find-dir d (cdr d*))))))) (emit* out "
 
" #\newline "" #\newline) (let y-loop ((grid '(("NW" "N" "NE") ("W" "" "E") ("SW" "S" "SE")))) (if (not (null? grid)) (begin (emit* out "" #\newline) (let x-loop ((row (car grid))) (if (null? row) (begin (emit* out "" #\newline) (y-loop (cdr grid))) (begin (emit* out "" #\newline) (x-loop (cdr row)))))))) (emit* out "
 ") (let ((dest (find-dir (car row) dir*))) (if dest (emit* out "" (car row) "") (emit* out (car row)))) (emit* out " 
" #\newline))) (define (split-desc s) (if (string? s) (list "" s "") s)) (define (emit-action* out page-id c* vertexes v-id state visited depth) (if (not (null? c*)) (emit* out "
" #\newline)) (let loop ((c* c*) (dir* '())) (if (null? c*) (if (not (null? dir*)) (make-nav-grid out dir*)) (let ((x (car c*))) (let ((a (mod-action x)) (new-v-id v-id) (new-state state)) (case (car a) ((go) (set! new-v-id (cadr a))) ((add) (if (memq (cadr a) state) (cycle (cadr a) v-id)) (set! new-state (cons (cadr a) state))) ((add/go) (if (memq (cadr a) state) (cycle (cadr a) v-id)) (set! new-state (cons (cadr a) state)) (set! new-v-id (caddr a))) ((rem) (set! new-state (remq (cadr a) state))) ((rem/go) (set! new-state (remq (cadr a) state)) (set! new-v-id (caddr a))) ((go/cut) (set! new-state (cut-props (cddr a) state)) (set! new-v-id (cadr a))) ((go/sel) (set! new-state (retain-props (cddr a) state)) (set! new-v-id (cadr a))) ((nop) 'nop) ((nop) 'nop) (else (adv-error v-id "bad action" (car a)))) (let* ((new-tag (cons new-v-id new-state)) (linked-vertex (hash-table-ref visited new-tag))) (if out (close-output-port out)) (let ((v (if linked-vertex (car linked-vertex) (render-vertex vertexes new-v-id new-state (+ 1 depth))))) (if out (set! out (append-to-output-file (make-path page-id)))) (cond ((and (string? (mod-link x)) (string=? "" (mod-link x))) (loop (cdr c*) dir*)) ((member (mod-link x) '("N" "E" "S" "W" "NE" "SE" "SW" "NW")) (loop (cdr c*) (cons (list v x) dir*))) (else (let ((s* (split-desc (mod-link x)))) (emit* out "
" (car s*) "" (cadr s*) "" (caddr s*) "
" #\newline)) (loop (cdr c*) dir*))))))))) (if (not (null? c*)) (emit* out "
" #\newline)) out) (define (true-conditions cond* state) (append-map (lambda (this-cond) (let loop ((c* (mod-cond this-cond))) (cond ((null? c*) (list this-cond)) ((or (and (symbol? (car c*)) (not (memq (car c*) state))) (and (pair? (car c*)) (memq (cadar c*) state))) '()) (else (loop (cdr c*)))))) cond*)) (define (find-vertex src vertexes v-id) (let ((v (hash-table-ref vertexes v-id))) (if v (car v) (adv-error src "no such vertex" v-id)))) (define (render-vertex vertexes v-id state depth) (if (eq? v-id *dest-node*) (if (or (not *min-depth*) (< depth *min-depth*)) (set! *min-depth* depth))) (let* ((vertex (find-vertex #f vertexes v-id)) (tag (cons (vertex-id vertex) state)) (c* (true-conditions (vertex-cond* vertex) state))) (let ((page-id (unique tag *hash-length*))) (if (and (opt-val verbose) (> (opt-val verbose) 1)) (display* "state: " tag #\newline)) (if (and (not (opt-val dry-run)) (not (file-exists? *dumpdir*))) (sys:mkdir *dumpdir*)) ((if (opt-val dry-run) call-with-dummy-file call-with-output-file) (make-path page-id) (lambda (out) (html-prelude out (make-heading v-id)) (if (opt-val state-comments) (emit* out "" #\newline)) (if (opt-val debug-info) (emit* out "

State: " tag "

" #\newline)) (hash-table-set! *visited* tag page-id) (emit* out (if (opt-val title-text) "

" "

") (make-heading (vertex-id vertex)) (if (opt-val title-text) "

" "") #\newline) (emit* out "

" #\newline) (let* ((desc (vertex-desc vertex)) (desc (if (and (pair? desc) (eq? 'copy-from (car desc))) (vertex-desc (find-vertex v-id vertexes (cadr desc))) desc))) (emit-desc out desc)) (emit-mod-desc* out c*) (emit* out "

" #\newline) (let ((out (emit-action* out page-id c* vertexes v-id state *visited* depth))) (html-postlude out)))) page-id))) (define (dump-state v-id vertexes) (render-vertex vertexes v-id '() 0)) (define (make-entry-page base) (if (not (opt-val dry-run)) (with-output-to-file (make-path "index") (lambda () (html-prelude (current-output-port) (if (opt-val title-text) (opt-val title-text) "The Beginning")) (cond ((opt-val intro-text) => (lambda (file) (with-input-from-file file (lambda () (copy-to (current-output-port))))))) (emit* "

Let the journey begin!

" #\newline) (html-postlude (current-output-port)))))) (define (advgen) (let* ((base+vertexes (read-description)) (base (car base+vertexes)) (vertexes (cadr base+vertexes)) (n-vertexes (length (hash-table->alist vertexes)))) (if base (let ((entry-page (dump-state base vertexes))) (make-entry-page entry-page) (if (opt-val verbose) (display* n-vertexes " vertexes read, " *vertex-counter* " states generated." #\newline)) (if (opt-val path-length) (if (not *min-depth*) (display* "there is no path to a vertex named \"" *dest-node* "\"" #\newline) (display* "shortest path to \"" *dest-node* "\": " *min-depth* " nodes" #\newline))))))) (define (usage) (display* "Usage: advgen [-bcdnrsv] [-e file] [-H length] [-i file]" "[-o path]" #\newline " [-p file] [-P node] [-t text] [-y url] [file]") (newline)) (let ((file (parse-options! (sys:command-line) options usage))) (if (opt-val show-help) (begin (display-usage `("" ,usage "" "Generate HTML text adventures" "" "-b emit bare HTML without headers or BODY tags" "-c include state comments in source files" "-d write visible state information to each page" "-e file copy page epilogue from file" "-H len hash length (file name length)" "-i file copy introduction text from file" "-n dry-run, do not emit any data" "-o path output path" "-p file copy page prologue from file" "-P node print the length of the shortest path to node" "-r remove left-over files before processing" " (will remove *all* files from destination!)" "-s squeeze out newlines to save space" "-t text title to be displayed on each page" "-y url link style sheet (not with -b)" "-v verbose operation" "")) (sys:exit))) (cond ((opt-val dumpdir) => (lambda (path) (set! *dumpdir* path)))) (cond ((opt-val path-length) => (lambda (path) (set! *dest-node* (string->symbol path))))) (cond ((opt-val hash-length) => (lambda (len) (set! *hash-length* len)))) (if (and (opt-val remove-old) (file-exists? *dumpdir*)) (for-each (lambda (name) (sys:unlink (string-append *dumpdir* "/" name))) (sys:readdir *dumpdir*))) (cond ((> (length file) 1) (usage) (sys:exit)) ((null? file) (advgen)) (else (with-input-from-file (car file) advgen)))) s9/prog/adventure.intro000644 001751 001751 00000001164 12014626620 015043 0ustar00nmhnmh000000 000000 Scheme 9 Mascot

S9fES is a mature, portable, and comprehensible public-domain interpreter for R4RS Scheme offering

  • support for low-level Unix programming
  • cursor addressing with Curses
  • decimal-based real number arithmetics
  • basic networking procedures
  • loads of useful library functions

So you want to get access to the latest S9fES source code?

Your mission is to get access to the terminal room of a cold, faceless concrete blockwellspring of creativity (a.k.a. college) and steal the code!

s9/prog/scmpp.scm000755 001751 001751 00000003425 11477627005 013636 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f ; scmpp -- Scheme pretty-printer ; by Nils M Holm, 2010 ; Placed in the Public Domain ; ; Usage: scmpp [-cds] [-m margin] [file ...] (load-from-library "pretty-print.scm") (load-from-library "parse-optionsb.scm") (define as-code (option #\c #f)) (define as-data (option #\d #f)) (define simple (option #\s #f)) (define margin (option #\m 'integer 72)) (define show-help (option #\h #f)) (define options `(,as-code ,as-data ,simple ,margin ,show-help)) (define (usage) (display "Usage: scmpp [-cds] [-m margin] [file ...]") (newline)) (let* ((files (parse-options! (sys:command-line) options usage))) (cond ((opt-val show-help) (display-usage `("" ,usage "" "Pretty-print Scheme code and objects" "" "-c assume that input is Scheme code" "-d assume that input is Scheme data" "-s use (one-line) simple forms where possible" "-m N set right margin to column N" "")) (sys:exit 0))) (let ((options (append (if (opt-val as-code) '(code) '()) (if (opt-val as-data) '(data) '()) (if (opt-val simple) '(simple) '()) (list 'margin: (opt-val margin))))) (if (null? files) (apply pp-loop options) (let loop ((files files)) (if (not (null? files)) (begin (apply pp-file (car files) options) (loop (cdr files)))))))) s9/prog/adventure.adv000644 001751 001751 00000057271 12745501520 014476 0ustar00nmhnmh000000 000000 ; ADVGEN sample adventure ; By Nils M Holm, 2010,2012 ; Placed in the Public Domain (street ("You are standing in front of a building in an anonymous city. There is" "a busy street nearby.") (((not closed)) () "Cross street" (add closed "There does not seem to be anything of interest there.")) ((closed) () "Cross street" (nop "There still does not seem to be anything of interest there.")) (((not closed)) () "Enter building" (go hall)) ((closed) () "Enter building" (go building:closed))) (building:closed ("You are standing in front of a building. The door of the building seems" "to be locked.") (() ("A look at the opening times reveals that they have closed" "just a few seconds earlier.") "" (nop))) (building:closed:2 (copy-from building:closed) (() ("A look at the opening times reveals that they are closed.") "" (nop))) (hall ("You are in a hall. Corridors extend to the east and the west." "There is an elevator to the north.") (() ("On the wall next to the elevator there is a sign reading:

" "
"
   "+-------------------+"
   "| 5. Administration |"
   "| 4. Data Center    |"
   "| 3. Research       |"
   "| 2. Service        |"
   "| 1. Lecture Rooms  |"
   "+-------------------+"
   "
" "

") "" (nop)) (() () "E" (go floor-1:5)) (() () "W" (go floor-1:1)) (() () "Take elevator" (go elevator))) (elevator ("You are in an elevator car.") (() () "[5]" (go 5th-floor)) (() () "[4]" (go 4th-floor)) (() () "[3]" (go 3rd-floor)) (() () "[2]" (go 2nd-floor)) (() () "[1]" (go hall))) (floor-1:1 ("You are in a corridor. There are lots of doors, but they do not" "look inviting. There is another corridor to the north/west. There is" "a hall to the east.") (() ("There is a public restroom here.") "" (nop)) (() () "Enter restroom" (go restroom)) (() () "NW" (go floor-1:2)) (() () "E" (go hall))) (restroom ("You are in a public restroom sporting the charm of a public restroom." "There are various writings on the door and the walls.") (((not peed)) () "Have a pee" (add peed "Much better!")) (() () "Study writings" (go restroom:2)) (() () "Leave the restroom" (go/cut floor-1:1 peed))) (restroom:2 ("Excluding the usual obscenities:

" "

\"You are not your stuff\"

" "

\"Mass of earth: 5.98e+24kg\"

" "

\"Quidquid latine dictum sit, altum viditur\"

" "

\"Beware of the Turing tar pit\"

" "

\"Preemptive War: Committing Suicide Out Of Fear Of Death\"

" "

\"RIP Scheme 2007\"

" "

\"Believe absurdities, commit atrocities\"

" "

\"Once persons were property, now property is a person\"") ((peed) ("

There also seems to be a map here.") "Look at the map" (go restroom:map)) (() () "Enough!" (go restroom))) (restroom:map ("

"
  "+----------------------------------------------+"
  "|                                              |"
  "|                                              |"
  "|     +----------------------------------+     |"
  "|     |                     |43x3        |     |"
  "|     |                     |            |     |"
  "|     |   You are here!     |             |    |"
  "|     |         |           |            |     |"
  "|     |         |           +------------|     |"
  "|     |    +----V+                       |     |"
  "|     |    |    o|                       |     |"
  "|     |    |  +--+    +--+               |     |"
  "|     |    |  |       |  |               |     |"
  "|     +-----__--------____---------------+     |"
  "|                                              |"
  "|                                              |"
  "+---------------------____---------------------+"
  "
") (() () "Aha" (go restroom))) (floor-1:2 ("You are in a corridor. There are lots of doors, but they do not" "look inviting. There are other corridors to the north/east and to the" "south/east.") (() () "NE" (go floor-1:3)) (() () "SE" (go floor-1:1))) (floor-1:3 ("You are in a corridor. There are lots of doors, but they do not" "look inviting. There are other corridors to the south/east and to the" "south/west.") (() () "SE" (go floor-1:4)) (() () "SW" (go floor-1:2))) (floor-1:4 ("You are in a corridor. There are lots of doors, but they do not" "look inviting. There are other corridors to the north/west and to the" "south/west.") (() ("One of the lecture rooms here is open.") "Enter lecture room" (go lecture-room)) (() () "NW" (go floor-1:3)) (() () "SW" (go floor-1:5))) (floor-1:5 ("You are in a corridor. There are lots of doors, but they do not" "look inviting. There is another corridor to the north/east. There is" "a hall to the west.") (() () "NE" (go floor-1:4)) (() () "W" (go hall))) (lecture-room ("You are in a lecture room. There are some people sitting in front of" "computer terminals. Some of them are taking an online quiz.") (() () "Also take the quiz" (go/sel quiz)) (() () "Leave lecture room" (go floor-1:4))) (quiz ("Question 1/3: what does the following expression evaluate to" "(according to R4RS)?

" "
(string->number \"#o777\" 10)

") (() () ("a: " "511" "") (add/go foo1.1 quiz:2)) (() () ("b: " "777" "") (add/go foo1.2 quiz:2)) (() () ("c: " "#f" "") (add/go foo1.3 quiz:2)) (() () ("d: " "511 or #f" "") (add/go one quiz:2))) (quiz:2 ("Question 2/3: what does the following program return?

" "
"
  "(map (let ((c 1))          "
  "       (lambda (x)         "
  "         (let ((n c))      "
  "           (set! c (+ 1 c))"
  "           (cons x n))))   "
  "     '(a b c))             "
  "

") (() () ("a: " "((a . 1) (b . 2) (c . 3))" "") (add/go foo2.1 quiz:3)) (() () ("b: " "((a . 3) (b . 2) (c . 1))" "") (add/go foo2.2 quiz:3)) (() () ("c: " "any combination of '(a b c) and '(1 2 3)" "") (add/go two quiz:3)) (() () ("d: " "none of the above" "") (go quiz:3))) (quiz:3 ("Question 3/3: What do you need to evaluate the following expression?" "

"
  "(((lambda (r)                                          "
  "   ((lambda (f) (f f))                                 "
  "    (lambda (f) (r (lambda x (apply (f f) x))))))      "
  "  (lambda (e)                                          "
  "    (lambda (v i l)                                    "
  "      (cond ((= v 0) (+ 1 l))                          "
  "            ((= v 1) (+ i l))                          "
  "            ((= l 1) i)                                "
  "            ((= v 2) (* i l))                          "
  "            ((= v 3) (expt i l))                       "
  "            (else    (e (- v 1) i (e v i (- l 1))))))))"
  " 6 6 6)                                                "
  "
") (() () ("a: " "nothing; that expression does not have a value" "") (add/go foo3.1 quiz:4)) (() () ("b: " "an ideal machine (with practically infinite memory)" "") (add/go three quiz:4)) (() () ("c: " "real number-crunching equipment (a supercomputer)" "") (add/go foo3.2 quiz:4)) (() () ("d: " "a faster PC and a few gigabytes of RAM" "") (go quiz:4))) (quiz:4 ("Question 4/3: As of 2008, which one was the last useful Scheme report?") (() () ("a: " "R3RS" "") (go quiz:end)) (() () ("b: " "R4RS" " (arguably)") (add/go foo4.1 quiz:end)) (((not one) (not two) (not three)) () ("c: " "R5RS" " (arguably)") (go quiz:end)) ((one (not two) (not three)) () ("c: " "R5RS" " (arguably)") (go quiz:end)) (((not one) two (not three)) () ("c: " "R5RS" " (arguably)") (go quiz:end)) ((one two (not three)) () ("c: " "R5RS" " (arguably)") (go quiz:end)) (((not one) (not two) three) () ("c: " "R5RS" " (arguably)") (go quiz:end)) ((one (not two) three) () ("c: " "R5RS" " (arguably)") (go quiz:end)) (((not one) two (not three)) () ("c: " "R5RS" " (arguably)") (go quiz:end)) ((one two three) () ("c: " "R5RS" " (arguably)") (go quiz:yay!)) (() () ("d: " "R6RS" "") (add/go foo4.2 quiz:end))) (quiz:end ("Naah, your score was not that brilliant. And while sitting" "there and causing yourself a headache, campus security arrived and" "found out that you are using LAB equipment without permission! You" "are being kicked out of the building.") (() () "More" (go building:closed:2))) (quiz:yay! ("While attempting to calculate your score, the program crashes." "Because you have shell access now, everybody thinks you are" "a student.") (() () "Cool!" (go terminal:session))) (2nd-floor (copy-from hall) (() () "E" (go floor-2:5)) (() () "W" (go floor-2:1)) (() () "Take elevator" (go elevator))) (floor-2:1 (copy-from floor-1:1) (() () "NW" (go floor-2:2)) (() () "E" (go 2nd-floor))) (floor-2:2 (copy-from floor-1:2) (() () "NE" (go floor-2:3)) (() () "SE" (go floor-2:1))) (floor-2:3 (copy-from floor-1:3) (((not hint)) ("One of the doors here looks somehow important.") "" (nop)) ((hint) ("There is the door of the college office here.") "Enter college office" (go college-office)) (() () "SE" (go floor-2:4)) (() () "SW" (go floor-2:2))) (college-office ("\"What do you want?\" asks an absent-minded woman.") ((need-degree) () "Enroll" (go college-office:degree:2)) (((not id) (not need-degree)) () "Enroll" (go college-office:enroll)) ((id (not need-degree)) () "Enroll" (go floor-2:3 "\"You already did!\"")) (() () "Leave the office" (go floor-2:3))) (college-office:enroll ("\"Which curriculum?\"") (() () "IT Fashion Design (a.k.a. \"Computer Science\")" (go college-office:degree)) (() () "Pharma Industry Sponsoring (a.k.a. \"Medicine\")" (go college-office:degree)) (() () "Naive Idealism (a.k.a. \"Social Studies\")" (go college-office:sure?)) (() () "Privateering (a.k.a. \"Business Arts\")" (go college-office:degree)) (() () "Leave the office" (go floor-2:3))) (college-office:degree ("\"I need to see your high-school degree!\"") (((not need-degree)) () "Leave the office" (add/go need-degree floor-2:3))) (college-office:degree:2 ("\"I already told you I need to see your high-school degree!\"") (() () "Leave the office" (go floor-2:3))) (college-office:sure? ("\"Are you sure?\"") (() () "Yes" (go college-office:ok)) (() () "No" (go college-office:enroll))) (college-office:ok ("\"But nobody wants to study that stuff these days! Well, it's" "your funeral. Here is your student's ID.\"") (((not id)) () "Take ID" (add/go id floor-2:3 "You take the ID and leave the college office.")) (() () "Leave the office" (go floor-2:3))) (floor-2:4 (copy-from floor-1:4) (() () "NW" (go floor-2:3)) (() () "SW" (go floor-2:5))) (floor-2:5 (copy-from floor-1:5) (() () "NE" (go floor-2:4)) (() () "W" (go 2nd-floor))) (3rd-floor (copy-from hall) (() () "E" (go floor-3:5)) (() () "W" (go floor-3:1)) (() () "Take elevator" (go elevator))) (floor-3:1 (copy-from floor-1:1) (() () "NW" (go floor-3:2)) (() () "E" (go 3rd-floor))) (floor-3:2 (copy-from floor-1:2) (() () "NE" (go floor-3:3)) (() () "SE" (go floor-3:1))) (floor-3:3 (copy-from floor-1:3) (() () "SE" (go floor-3:4)) (() () "SW" (go floor-3:2))) (floor-3:4 (copy-from floor-1:4) (() () "NW" (go floor-3:3)) (() () "SW" (go floor-3:5))) (floor-3:5 (copy-from floor-1:5) ((refered-to-postdoc (not hint)) ("The professor's post-doc's office is to the north.") "Knock on the door" (go postdocs-office "He calls you in immediately.")) ((refered-to-postdoc hint) ("The professor's post-doc's office is to the north.") "Knock on the door" (go postdocs-office:again "He calls you in immediately.")) (() () "NE" (go floor-3:4)) (() () "W" (go 3rd-floor))) (postdocs-office ("You are in the post-doc's office. It looks like a mess. There is" "a stack of pizza boxes on the desk and empty diet coke cans cover" "the floor. The guy himself looks like the archetypal hacker." "He does not seem to be interested in grants or, for that matter," "in anything but hacking. After a quick glance, he inquires: \"So" "you want access to the terminal room. Are you a student?\"") (() () "Yes" (go floor-3:5 "\"You need to go to the dispatch! Goodbye!\"")) (() () "No" (go postdocs-office:2))) (postdocs-office:2 ("\"This is interesting,\" the hacker says, \"you will need to go" "to the college office and enroll. Best pick a curriculum that is" "of no big interest these days. Good luck!\"") ((hint) () "Leave the office" (go floor-3:5)) (((not hint)) () "Leave the office" (add/go hint floor-3:5))) (postdocs-office:again ("You are in the post-doc's office. Again. It still looks like a mess." "The guy still looks like a hacker, only more annoyed." "\"I already told you how to do it! What do you want me to" "do? Hold your hand?\" With these words he points you to the door.") (() () "Leave" (go floor-3:5))) (4th-floor (copy-from hall) (() () "E" (go floor-4:5)) (() () "W" (go floor-4:1)) (() () "Take elevator" (go elevator))) (floor-4:1 (copy-from floor-1:1) (() () "NW" (go floor-4:2)) (() () "E" (go 4th-floor))) (floor-4:2 (copy-from floor-1:2) (() ("There is a glass door to the east. Behind the door you see" "people working on computer terminals.") "" (nop)) (((not card)) () "Enter terminal room" (nop "You need a magnetic card to enter the room.")) ((card) () "Enter terminal room" (go terminal-room)) (() () "NE" (go floor-4:3)) (() () "SE" (go floor-4:1))) (floor-4:3 (copy-from floor-1:3) (() () "SE" (go floor-4:4)) (() () "SW" (go floor-4:2))) (floor-4:4 (copy-from floor-1:4) (() ("There is a door labeled \"DISPATCH\" here.") "" (nop)) ((id) () "Enter DISPATCH" (go dispatch)) (((not id)) () "Enter DISPATCH" (go dispatch:no-student)) (() () "NW" (go floor-4:3)) (() () "SW" (go floor-4:5))) (dispatch:no-student ("There is an elderly woman sitting at a computer terminal behind" "an old wooden desk. She looks up as you enter. \"Sorry, you do not" "appear to be a student. I am afraid I cannot help you.\"") (() () "Leave the DISPATCH" (go floor-4:4))) (dispatch ("There is an elderly woman sitting at a computer terminal behind" "an old wooden desk. She looks up as you enter. \"What can I do for" "you?\"") (((not card)) () "Sign up for access to the terminal room" (go dispatch:signup)) ((card) () "Sign up for access to the terminal room" (nop "\"You already have access to the terminal room!\"")) (((not card)) () "Forgot my password" (nop "\"You do not even have an account. How can you have a password?\"")) ((card (not passwd)) () "Forgot my password" (add/go passwd dispatch:passwd)) ((passwd) () "Forgot my password" (go dispatch:passwd-again)) (() () "Leave the DISPATCH" (go floor-4:4))) (dispatch:signup ("\"You will need a magnetic card to get access to that room.\"" "The woman extends a hand holding a card.") (((not card)) () "Take card and leave" (add/go card floor-4:4))) (dispatch:passwd ("\"You do not yet have a password. I was just about to" "send it out in the mail.\"" "She then tells you your password.") (() () "Thanks!" (go floor-4:4))) (dispatch:passwd-again ("\"But I just gave it to you. *Sigh*. Here is a" "fresh one. Memorize it well, but do not write it down!") (() () "Umm, thanks!" (go floor-4:4))) (floor-4:5 (copy-from floor-1:5) (() () "NE" (go floor-4:4)) (() () "W" (go 4th-floor))) (5th-floor (copy-from hall) (() () "E" (go floor-5:5)) (() () "W" (go floor-5:1)) (() () "Take elevator" (go elevator))) (floor-5:1 (copy-from floor-1:1) (() () "NW" (go floor-5:2)) (() () "E" (go 5th-floor))) (floor-5:2 (copy-from floor-1:2) (() () "NE" (go floor-5:3)) (() () "SE" (go floor-5:1))) (floor-5:3 (copy-from floor-1:3) (() ("One door sign catches your eye. This is the office of a" "professor whom you know vaguely.") "" (nop)) (() () "Knock on his door" (go floor-5:3:knocked)) (() () "SE" (go floor-5:4)) (() () "SW" (go floor-5:2))) (floor-5:3:knocked ("You knock on the professor's door. There is no response.") (() () "Knock again" (go floor-5:3:knocked-again)) (() () "Give up" (go floor-5:3)) (() () "SE" (go floor-5:4)) (() () "SW" (go floor-5:2))) (floor-5:3:knocked-again ("You knock harder on the professor's door. There is still no response." "However you can hear someone shuffling inside.") (() () "Enter anyways" (go professors-office)) (() () "Give up" (go floor-5:3)) (() () "SE" (go floor-5:4)) (() () "SW" (go floor-5:2))) (professors-office ("You are in the professor's office. He is sitting in front of a" "computer terminal, frantically clicking on the cells of a spread" "sheet, muttering something about grants.") (() () "Say \"hello\"" (go professors-office:2)) (() () "Cough" (go professors-office:2)) (() () "Touch his shoulder" (go security)) (() () "Give up" (go floor-5:3))) (professors-office:2 (copy-from professors-office) (() () "Say \"hello\"" (go professors-office:3)) (() () "Cough" (go professors-office:3)) (() () "Touch his shoulder" (go security)) (() () "Give up" (go floor-5:3))) (professors-office:3 (copy-from professors-office) (() () "Say \"hello\"" (go professors-office:4)) (() () "Cough" (go professors-office:4)) (() () "Touch his shoulder" (go security)) (() () "Give up" (go floor-5:3))) (professors-office:4 ("You are in the professor's office. He is still sitting in front of" "his computer terminal, clicking and muttering. Without really noticing" "you, he refers you to his post-doc's office.") (() () "Thank him" (go professors-office:5)) ((refered-to-postdoc) () "Leave the office" (go floor-5:3)) (((not refered-to-postdoc)) () "Leave the office" (add/go refered-to-postdoc floor-5:3))) (professors-office:5 ("You are in the professor's office. He is still sitting in front of" "his computer terminal, obsessed about his spread sheet. Maybe it" "is time to leave him alone.") ((refered-to-postdoc) () "Leave the office" (go floor-5:3)) (((not refered-to-postdoc)) () "Leave the office" (add/go refered-to-postdoc floor-5:3 "\"Floor three,\" he mumbles as you close the door."))) (security ("The professor is shocked by the sudden return to reality. He starts" "to scream. A few seconds later campus security arrives and kicks you" "out of the building") (() () "More" (go building:closed:2))) (floor-5:4 (copy-from floor-1:4) (() () "NW" (go floor-5:3)) (() () "SW" (go floor-5:5))) (floor-5:5 (copy-from floor-1:5) (() () "NE" (go floor-5:4)) (() () "W" (go 5th-floor))) (terminal-room ("You are in a room full of computer terminals. A hacker's paradise!") (((not passwd)) () "Sit down at a terminal and log in" (go terminal:no-passwd)) ((passwd) () "Sit down at a terminal and log in" (go/sel terminal)) (() () "Leave the terminal room" (go floor-4:2))) (terminal:no-passwd ("You sit in front of a terminal and look at the

" "
login: _
" "

prompt. You are a bit clueless. Did the lady in the DISPATCH" "give you a password?") (() () "Get up" (go terminal-room))) (terminal ("You are sitting in front of a terminal. You are logged-in. What do" "you want to do?") (() () "Configure the shiny GUI" (go terminal:window-shopping)) (() () "Visit some social news site" (go terminal:procrastinating)) (() () "Open an X-terminal and start exploring" (go terminal:explore))) (terminal:window-shopping ("Configuring the GUI is a total fun! Look at all those flashy icons!") (() () "Keep tweaking" (go terminal:window-shopping:2)) (() () "Do something else" (go terminal))) (terminal:window-shopping:2 ("Now it looks nice! Let's just choose a cooler font and make the" "background image a bit more 1337!") (() () "Keep tweaking" (go terminal:window-shopping:3)) (() () "Do something else" (go terminal))) (terminal:window-shopping:3 ("Now this is a totally bad-ass-looking desktop! Just a little bit more" "tweaking.") (() () "Keep tweaking" (go terminal:window-shopping:3)) (() () "Do something else" (go terminal))) (terminal:procrastinating ("Now have you seen the latest shit in Web design? Awesome!") (() () "Keep surfing, dude" (go terminal:procrastinating:2)) (() () "Do something else" (go terminal))) (terminal:procrastinating:2 ("Wow, your favorite celeb is on twitter!") (() () "Keep surfing, dude" (go terminal:procrastinating:3)) (() () "Do something else" (go terminal))) (terminal:procrastinating:3 ("Some mega-corp has invented a totally hot, new programming language!" "OK, it is based on a design of the 1950's, but who cares? It's hot!") (() () "Keep surfing, dude" (go terminal:procrastinating:4)) (() () "Do something else" (go terminal))) (terminal:procrastinating:4 ("Ah, look! LOL cats!!1 Hahaha!") (() () "Keep surfing, dude" (go terminal:procrastinating:5)) (() () "Do something else" (go terminal))) (terminal:procrastinating:5 ("Let me just look this up in Wikipedia.") (() () "Keep surfing, dude" (go terminal:procrastinating)) (() () "Do something else" (go terminal))) (terminal:explore ("*Ahem* Are you sure? Only CS majors and terrorists" "use a command line interface these days!") (() () "I am a CS major" (go terminal:explore:cs-major)) (() () "I am a terrorist" (go terminal:explore:terrorist)) (() () "I just accidentally clicked this!" (go terminal:explore:suspect)) (() () "I am a hacker" (go terminal:explore:hacker)) (() () "I am an old fart and GUIs give me the creepies" (go terminal:explore:old-fart))) (terminal:explore:cs-major ("No you are not! Campus security arrives promptly and kicks you out" "of the building.") (() () "More" (go building:closed:2))) (terminal:explore:terrorist ("Haha, funny! But just in case campus security will kick you out of" "the building anyway, so the college cannot be sued if you should" "turn out to be a real terrorist.") (() () "More" (go building:closed:2))) (terminal:explore:suspect ("That's what a terrorist would say! After getting kicked out" "by campus security you sit in front of the closed door of the building." "A black van with tinted windows and missing license plates approaches.")) (terminal:explore:hacker ("Claiming to be a hacker is still a good defense against being" "suspected to be a hacker.") (() () "The X-terminal opens" (go terminal:session))) (terminal:explore:old-fart ("Oh, sorry! Did not see the wrinkles!") (() () "The X-terminal opens" (go terminal:session))) (terminal:session ("

$ ls -l" "
$ cat" "prog/adventure.adv

")) s9/prog/s9hts.scm000755 001751 001751 00000021326 11776746635 013603 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f ; s9hts -- hyper text server ; by Nils M Holm, 2010,2012 ; Placed in the Public Domain ; ; Usage: s9hts [-m sec] [host [port]] (load-from-library "inet-server.scm") (load-from-library "url-decode.scm") (load-from-library "split-url.scm") (load-from-library "hash-table.scm") (load-from-library "string-position.scm") (load-from-library "string-parse.scm") (load-from-library "string-unsplit.scm") (load-from-library "string-find.scm") (load-from-library "read-line.scm") (load-from-library "displaystar.scm") (load-from-library "parse-optionsb.scm") (load-from-library "spawn-command.scm") (load-from-library "format-time.scm") (load-from-library "unix-time-to-time.scm") (define show-help (option #\h #f)) (define max-req (option #\m 'integer 5)) (define options `(,max-req ,show-help)) (define (usage) (display "Usage: s9hts [-m nreq] [host [port]]"); (newline)) (define CR (integer->char 13)) (define CRLF (string CR #\newline)) (define (status out n . type) (let ((msg (case n ((200) "ok") ((400) "huh?") ((404) "not here") ((500) "oops - I blew it") ((503) "bug me not")))) (display* out "HTTP/1.0 " n #\space msg CRLF) (if (not (null? type)) (display* out "Content-type: " (car type) CRLF CRLF)))) (define (last x) (car (reverse x))) (define (trim-empty a) (letrec ((trim (lambda (x) (if (and (not (null? x)) (equal? "" (car x))) (trim (cdr x)) x)))) (trim (reverse! (trim (reverse a)))))) (define (cant-parse out request) (status out 400 "text/html") (display* out "

400 huh?

" #\newline) (display* out "

Request: " request "

" #\newline)) (define (not-found out file) (status out 404 "text/html") (display* out "

404 not here

" #\newline) (display* out "

Path: " file "

" #\newline)) (define (bug-me-not out) (status out 503 "text/html") (display* out "

503 bug me not!

" #\newline)) (define (set-url-path! url path) (set-car! (cddr url) path)) (define (set-url-suffix! url suffix) (set-car! (cdddr url) suffix)) (define (local-path? s) (let loop ((in (string->list s)) (depth 0)) (cond ((null? in)) ((char=? #\/ (car in)) (if (and (> (length in) 3) (string=? "/.." (string (car in) (cadr in) (caddr in)))) (if (zero? depth) #f (loop (cdr in) (- depth 1))) (loop (cdr in) (+ 1 depth)))) (else (loop (cdr in) depth))))) (define (mime-type suffix) (let ((table '(((#f) "text/plain") (("html" "htm") "text/html") (("css") "text/css") (("jpg" "jpeg") "image/jpeg") (("png") "image/png") (("gif") "image/gif") (("tar") "application/x-tar") (("gz" "tgz") "application/x-gzip") (("zip") "application/zip")))) (let loop ((table table)) (cond ((null? table) "application/octet-stream") ((member suffix (caar table)) (cadar table)) (else (loop (cdr table))))))) (define (run-script out path args) (let* ((conn (spawn-command path)) (script-in (car conn)) (script-out (cadr conn)) (args (map (lambda (x) (cons (car x) (url-decode (cdr x)))) args))) (if args (begin (display args script-out) (newline script-out) (close-output-port script-out))) (let loop ((c (read-char script-in))) (if (not (eof-object? c)) (begin (write-char c out) (loop (read-char script-in))))))) (define (serve out url) (cond ((and (url-suffix url) (string=? "cgi" (url-suffix url))) (status out 200) (run-script out (url-path url) (url-args url))) (else (status out 200 (mime-type (url-suffix url))) (with-input-from-file (url-path url) (lambda () (let loop ((c (read-char))) (if (not (eof-object? c)) (begin (write-char c out) (loop (read-char)))))))))) (define (log-stuff code time peer header) (let ((tstp (format-time "~w ~4y-~m-~2d ~2h:~2m:~2s" (unix-time->time time)))) (display* #\" code #\" #\space #\" tstp #\" #\space #\" (if peer (car peer) "unknown") #\" #\space #\" (cadr (string-split #\space (car header))) #\" #\space #\" (get-user-agent header) #\" #\newline))) (define (http-request out old time peer header) (let ((request (string-parse " " (car header)))) (cond ((not (<= 2 (length request) 3)) (log-stuff 400 time peer header) (cant-parse out (string-unsplit #\space request))) ((not (string=? "GET" (car request))) (log-stuff 400 time peer header) (cant-parse out (string-unsplit #\space request))) (else (let* ((url (split-url (cadr request))) (_ (set-url-path! url (string-append "." (url-path url)))) (url (begin (if (and (sys:stat (url-path url)) (sys:stat-directory? (url-path url))) (begin (set-url-path! url (string-append (url-path url) "/index.html")) (set-url-suffix! url "html"))) url))) (cond ((not (local-path? (url-path url))) (log-stuff 503 time peer header) (bug-me-not out)) ((file-exists? (url-path url)) (log-stuff 200 time peer header) (serve out url)) (else (log-stuff 404 time peer header) (not-found out (cadr request))))))))) (define (get-user-agent header) (let* ((uah "User-Agent: ") (k (string-length uah))) (let loop ((h header)) (cond ((null? h) "unidentified") ((and (>= (string-length (car h)) k) (string-ci=? (substring (car h) 0 k) uah)) (substring (car h) k (string-length (car h)))) (else (loop (cdr h))))))) (define (old-request? s) (let ((s (string-parse " " s))) (and (= (length s) 2) (>= (string-length (car s)) 3) (string=? "GET" (substring (car s) 0 3))))) (define (handle-request in out peer time delta) (if (and delta (< delta 1)) (bug-me-not out) (let loop ((line (read-line in)) (header '())) (let* ((k (if (eof-object? line) -1 (- (string-length line) 1))) (line (if (and (not (negative? k)) (char=? CR (string-ref line k))) (substring line 0 k) line))) (cond ((or (eof-object? line) (string=? "" line)) (http-request out #f time peer (reverse header))) ((old-request? line) (handle-request out #t time peer (list line))) (else (loop (read-line in) (cons line header)))))))) (define (server) (let ((args (parse-options! (sys:command-line) options usage))) (if (opt-val show-help) (begin (display-usage `("" ,usage "" "Hypertext Server" "" "-m nreq max. requests/second per client (default: 5)" "")) (sys:exit 0))) (let ((host (if (null? args) #t (car args))) (port (if (or (null? args) (null? (cdr args))) "80" (cadr args)))) (inet-server host port handle-request (opt-val max-req))))) (server) s9/prog/cols.scm000755 001751 001751 00000004503 12537016051 013441 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f ; cols -- format input in two columns ; by Nils M Holm, 2010 ; Placed in the Public Domain ; ; Usage: cols [-l] [-s separator] [file ...] (load-from-library "parse-optionsb.scm") (load-from-library "displaystar.scm") (load-from-library "read-file.scm") (load-from-library "split.scm") (load-from-library "appendb.scm") (define pad-left (option #\l #f)) (define separator (option #\s 'string " ")) (define show-help (option #\h #f)) (define options `(,pad-left ,separator ,show-help)) (define (pad k s) (make-string (- k (string-length s)) #\space)) (define (cols) (let* ((col* (split (read-file))) (kl (apply max (cons 0 (map string-length (car col*))))) (kr (apply max (cons 0 (map string-length (cadr col*)))))) (if (> (length (car col*)) (length (cadr col*))) (if (null? (cadr col*)) (set-car! (cdr col*) '("")) (append! (cadr col*) '("")))) (for-each (lambda (left right) (if (opt-val pad-left) (display* (pad kl left) left (opt-val separator) (pad kr right) right #\newline) (display* left (pad kl left) (opt-val separator) right (pad kr right) #\newline))) (car col*) (cadr col*)))) (define (usage) (display "Usage: cols [-l] [-s separator] [file ...]") (newline)) (let ((files (parse-options! (sys:command-line) options usage))) (if (opt-val show-help) (begin (display-usage `("" ,usage "" "Format input in two columns" "" "-l pad on the left (default: right)" "-s string column separator (default: \" \")" "")) (sys:exit 0))) (if (null? files) (cols) (let loop ((files files)) (if (not (null? files)) (begin (with-input-from-file (car files) cols) (loop (cdr files))))))) s9/prog/edoc.css000644 001751 001751 00000001632 12357041122 013413 0ustar00nmhnmh000000 000000 BODY { color: #000000; line-height: 150%; background: #e8e0c0; } CODE { font-family: courier; font-weight: bold; color: #6000c0; } A { background: #ffffe0; } A:link { text-decoration: none; border: 1px dotted #0000ff; } A:visited { text-decoration: none; border: 1px dotted #0000ff; } VAR { color: #000080; font-style: italic; } EM { font-style: italic; } BLOCKQUOTE { border-style: none; border-left-style: solid; border-width: 0; border-left-width: 0.5em; border-color: #808080; padding-left: 0.5em; margin-right: 1.5em; margin-left: 1.5em; } PRE { background: #e8f4f8; border: 1px solid #808080; padding: 0.5em; } IMG { border-color: #808080; border-width: 1px; border-style: solid; padding: 0; margin: 0; margin-top: 0.5em; } margin-bottom: 0.5em; } s9/prog/s9symbols.scm000644 001751 001751 00000004106 12054356445 014451 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f ; s9symbols -- print S9 symbols ; by Nils M Holm, 2012 ; Placed in the Public Domain ; ; This procedure extracts all symbols from the S9 help files and ; dumps them to the output port. The resulting list can be used ; as an auto-completion list for the S9 editor. ; ; Usage: s9symbols (load-from-library "displaystar.scm") (load-from-library "find-help-path.scm") (load-from-library "read-line.scm") (load-from-library "string-parse.scm") (load-from-library "list-to-set.scm") (load-from-library "remove.scm") (load-from-library "hof.scm") (load-from-library "sort.scm") (define LP #\() (define RP #\)) (define (extract-symbols-from-file path) (with-input-from-file path (lambda () (let loop ((line (read-line)) (syms '())) (if (or (eof-object? line) (string=? "" line)) (if (null? syms) '() (reverse! (list->set syms))) (let* ((s* (string-split LP line)) (s* (if (> (length s*) 1) (cadr s*) "")) (s* (string-parse (string #\space RP) s*)) (s* (if (not (null? s*)) (car s*) ""))) (loop (read-line) (cons s* syms)))))))) (let* ((hpath (find-help-path)) (files (if hpath (sys:readdir hpath) '())) (files (apply append (map (lambda (x) (let ((file (string-append hpath "/" x))) (if (sys:lstat-regular? file) (list x) '()))) files))) (topics (apply append (map (lambda (file) (extract-symbols-from-file (string-append hpath "/" file))) files))) (topics (remove "" (sort string-ci<=? topics)))) (for-each (curryr display* #\newline) topics)) s9/prog/edoc.scm.edoc000755 001751 001751 00000157362 12361765116 014350 0ustar00nmhnmh000000 000000 #! /usr/local/bin/s9 -f #|edoc code|# ; edoc -- embedded documentation processor ; By Nils M Holm, 2010,2012,2014 ; Placed in the Public Domain #|edoc------------------------------------------------------------------ \1{EDOC} \2{An Embedded Documentation Processor} EDOC is a text processor that renders Scheme and C programs with embedded documentation in EDOC format to HTML. This file is an EDOC document and the program implementing EDOC at the same time. When run in a Scheme system, it processes EDOC documents, and when passed to EDOC, it results in the documentation for the program, including its own syntax-highlighted source code. To convert this file to HTML, run \b{edoc.scm.edoc -l scheme -o edoc.html edoc.scm.edoc} To extract the pure Scheme code, run \b{edoc.scm.edoc -l scheme -o edoc.scm -s edoc.scm.edoc} However, the program can also be run with the EDOC sections in place. \2{EDOC Format} Embedded documentation is enclosed by a line starting with the string "#|edoc" (in Scheme) or "/*edoc" (in C). Its ends with a line ending in "code|#" (Scheme) or "code*/" (C). Lines of the forms \b{ "#|edoc ... code|#" "/*edoc ... code*/" } (without the quotes) are ignored completely, but may be used to set the language type at the beginning of a file. Lines of the form \b{ "#|edoc reset code|#" "/*edoc reset code*/" } are also ignored but in addition they reset the language type, so they can be used to compile bilingual files. A trailing backslash may be used to concatenate subsequent lines: \b{ foo\\ bar } parses as \k{foobar}. Embedded documentation may contain the following commands. \v{Mode}s may contain \v{attributes}, but not vice versa. Attributes must begin and end in the same line. Neither \v{mode}s nor \v{attribute}s may be nested. The following \v{mode}s exist: \b{ \\q{edoc-text\=} quoted text
\\b{edoc-text\=} block text 
\\u{edoc-text\=}              unsorted list      
    
\\o{edoc-text\=}              ordered list       
      
\\0{edoc-text file-name\=}    new part           
      
\\1{edoc-text\=}              new chapter        
      
\\2{edoc-text\=}              new section        
      
\\3{edoc-text\=}              new subsection     
      
\\i{file\=}                   image              
}

These \v{attribute}s exist:

\b{
\\a{text\=}         anchor               
\\r{text url\=}     reference            text
\\s{text\=}         small                
\\v{text\=}         variable             
\\k{text\=}         keyword              
\\e{text\=}         emphasis             
\\E{text\=}         strong emphasis      
\\h{text\=}         highlight            
\\l{text\=}         list element         
    1. 
\\x{text name\=}    index entry          text
\\X{text name\=}    code index entry     text
\\n{text\=}         non-printing index   
\\V{text name\=}    variable index entry text
\\_{text\=}         subscript            
\\^{text\=}         superscript          
\\\\               literal backslash    literal
\\=c              literal character    literal
}

Setting the \v{name} in \\x, \\X, and \\V to \k{*} duplicates the
preceding text, e.g.: \\x{foo *\=} equals \\x{foo foo\=}. Omitting
the \v{name} in \\x, \\X, and \\V will generate an index entry that
uses \v{text} as \v{name} and will not be visible in the text.
The \v{name} part of an index entry is what will appear in the index
and its \v{text} is what will be highlighted in the content. The
\\n attribute can be used to create multi-word index entries that
are invisible in the content.

The CSS2 style sheets "scheme.css" and "ccode.css" contain the
default styles for syntax highlighting. The "edoc.css" style
sheet may be used to define other markup.

\e{Note}: EDOC handles only subsets of R4RS Scheme and C89 properly.
\e{Caveat utilitor!}

\2{Synopsis}\a{synopsis}

\b{
edoc [-iswL] [-b file] [-l lang] [-o file] [-t text] [-x name] [file ...]

Render programs with embedded edoc sections in HTML

-b file  make file headings link back to 'file'
-i       generate index file (INDEX)
-l lang  source language is lang (scheme, ccode)
-o file  write output to the given file
-s       strip edoc sections, output raw code
-t text  content of the HTML TITLE tag
-w       overwrite output files (default: keep)
-x name  extract section with given file name
-E file  insert epilogue 'file' at end of output
-P file  insert prologue 'file' at beginning of output
-L       generate Lout output (experimental!)
}

\2{The EDOC Source Code}

First load some required procedures. "when.scm" contains the \k{when}
syntax (single-branch \k{if} with multiple statements in the body),
"setters.scm" provides some convenience procedures, such as \k{inc!}
and \k{dec!} (for incrementing and decrementing variables).

------------------------------------------------------------------code|#

(load-from-library "when.scm")
(load-from-library "setters.scm")

#|edoc------------------------------------------------------------------

\k{String-scan} returns the position of a character in a string (or
\k{#f}). \k{String-translate} replaces characters in strings.

------------------------------------------------------------------code|#

(load-from-library "string-scan.scm")
(load-from-library "string-translate.scm")

#|edoc------------------------------------------------------------------

\k{Display*} is a multi-argument version of \k{display}. \k{Read-line}
reads a line from an input port.

------------------------------------------------------------------code|#

(load-from-library "displaystar.scm")
(load-from-library "read-line.scm")

#|edoc------------------------------------------------------------------

\k{Scm2html} and \k{c2html} render Scheme and C code in HTML (or Lout)
with syntax highlighting. They are used to render embedded code.
\k{Htmlify-char} and \k{loutify-char} translate "dangerous" characters
into harmless sequences, e.g. "&" to "&" in HTML and "/" into ""/""
in Lout.

------------------------------------------------------------------code|#

(load-from-library "scm2html.scm")
(load-from-library "c2html.scm")
(load-from-library "htmlify-char.scm")
(load-from-library "loutify-char.scm")

#|edoc------------------------------------------------------------------

\k{Append-to-output-file} is like \k{open-output-file}, but appends
output to an existing file instead of truncating it.
"standard-error.scm" contains the \k{with-output-to-stderr} procedure,
which redirects the current output port to stderr.

------------------------------------------------------------------code|#

(load-from-library "append-to-output-file.scm")
(load-from-library "standard-error.scm")

#|edoc------------------------------------------------------------------

\k{Parse-options!} parses command line options automatically.
The \k{option} procedure, which is contained in the same package,
sets up an option for parsing and \k{opt-val} returns the value of
an option, which is either a value taken from the command line or
a default specified in \k{option}.

------------------------------------------------------------------code|#

(load-from-library "parse-optionsb.scm")

#|edoc------------------------------------------------------------------

A hash table is used to generate unique index tags.

------------------------------------------------------------------code|#

(load-from-library "hash-table.scm")

#|edoc------------------------------------------------------------------

\k{*Language*} is the language to process. Must be either \k{'ccode} or
\k{'scheme}. \k{*Title*} is the title of a resulting HTML document
(default is the file name). \k{*File-name*} holds the file name of the
current input file. \k{*Extracting*} is set to \k{#t} when extracting a
section (see \k{-x} option).

------------------------------------------------------------------code|#

(define *language*    #f)
(define *title*       #f)
(define *file-name*   #f)
(define *extracting*  #f)

#|edoc------------------------------------------------------------------

\k{*Output-port*} is the current output port and \k{*to-file*} is the
name of the file currently being written. \k{*Ndx-port*} is the port
of the index file.

------------------------------------------------------------------code|#

(define *output-port* (current-output-port))
(define *to-file*     #f)
(define *ndx-port*    #f)

#|edoc------------------------------------------------------------------

\k{*Line-no*} will be incremented when reading a new line.

------------------------------------------------------------------code|#

(define *line-no* 0)

#|edoc------------------------------------------------------------------

\k{*Index-tags*} contains all index tags contained by a document. Since
multiple entries with the same name may exist, tags have a unique number
appended to them. This table keeps track of the unique suffixes.

------------------------------------------------------------------code|#

(define *index-tags* (make-hash-table))

#|edoc------------------------------------------------------------------

Command line options have one of these formats:

\b{
(option opt-char #t | #f)
(option opt-char 'string "default" | #f)}

\v{Opt-char} is the option character. When \k{'string} is present, the
option takes an argument. The last element in \k{option} is the default
value of that option.

\k{Options} is a list of all options.

See the \r{synopsis #synopsis} for explanation of the
individual options.

------------------------------------------------------------------code|#

(define show-help     (option #\h #f))
(define backlink      (option #\b 'string #f))
(define make-index    (option #\i #f))
(define language      (option #\l 'string #f))
(define output-file   (option #\o 'string #f))
(define strip-doc     (option #\s #f))
(define title         (option #\t 'string ""))
(define extract       (option #\x 'string #f))
(define lout          (option #\L #f))
(define overwrite     (option #\w #f))
(define prologue-file (option #\P 'string #f))
(define epilogue-file (option #\E 'string #f))
(define options       `(,show-help
                        ,backlink
                        ,make-index
                        ,language
                        ,output-file
                        ,strip-doc
                        ,title
                        ,extract
                        ,overwrite
                        ,prologue-file
                        ,epilogue-file
                        ,lout))

#|edoc------------------------------------------------------------------

Print an error message with an optional argument to stderr and exit.

------------------------------------------------------------------code|#

(define (edoc-error msg . arg)
  (with-output-to-stderr
    (lambda ()
      (display* "edoc: "
                *line-no*
                ": error: "
                msg
                (if (null? arg) "" ": ")
                (if (null? arg) "" (car arg))
                #\newline)
      (sys:exit 1))))

#|edoc------------------------------------------------------------------

Set \k{*language*}. This will be done each time an EDOC section is
found. Once the language is set, it cannot be changed unless it is
reset to \k{#f} first.

------------------------------------------------------------------code|#

(define (set-language! x)
  (if (and *language*
           (not (eq? x *language*)))
      (edoc-error "conflicting language specification" x))
  (set! *language* x))

#|edoc------------------------------------------------------------------

Print a sequence of objects to the current output file. This is the
principal output procedure of EDOC.

------------------------------------------------------------------code|#

(define (pr . items)
  (for-each (lambda (x)
              (display x *output-port*))
            items))

#|edoc------------------------------------------------------------------

Close current output file.

------------------------------------------------------------------code|#

(define (close-file)
  (if *to-file*
      (close-output-port *output-port*)))

#|edoc------------------------------------------------------------------

Move to next output file by closing the old one and then opening the
one specified in \v{name}. If the \v{overwrite} option is true, delete
the new output file before opening it for output.

------------------------------------------------------------------code|#

(define (next-output-file name)
  (close-file)
  (if (and (opt-val overwrite)
           (file-exists? name))
      (delete-file name))
  (set! *output-port* (open-output-file name))
  (set! *to-file* name))

#|edoc------------------------------------------------------------------

Copy the file named \v{file} to the current output file.

------------------------------------------------------------------code|#

(define (copy-file file)
  (if (not (file-exists? file))
      (edoc-error "file not found" file))
  (with-input-from-file
    file
    (lambda ()
      (let copy ((c (read-char)))
        (cond ((not (eof-object? c))
                (write-char c *output-port*)
                (copy (read-char))))))))

#|edoc------------------------------------------------------------------

Emit the HTML and Lout prologues, respectively. The title of an HTML
file will be the file name or, if specified on the command line, a
user-defined title. When both are present, they will be separated
by a colon, file name first.

------------------------------------------------------------------code|#

(define (html-prologue)
  (for-each
    pr
    `(""    #\newline
       ""                                         #\newline
       ""                                         #\newline
       ""
       ,(if *file-name* *file-name* "")
       ,(if (and *title* *file-name*) " : " "")
       ,(if *title* *title* "")
       ""                                       #\newline
       ""                            #\newline
       ""                          #\newline
       ""                           #\newline
       ""                                        #\newline
       ""                                         #\newline
       #\newline)))

(define (lout-prologue)
  (for-each
    pr
    `("@Include { S9Book }"                #\newline
      "@Use { @BookSetup"                  #\newline
      "    @DocumentHeight { 27.9c}"       #\newline
      "    @DocumentWidth { 21c}"          #\newline
      "    @TopMargin { 1.5c }"            #\newline
      "    @BottomMargin { 0.5c }"         #\newline
      "    @InnerMargin{ 2.5c }"           #\newline
      "    @OuterMargin { 1.5c }"          #\newline
      "    @Spacing { 1.25fx }"            #\newline
      "    @SkipPageNos { 1 2 3 }"         #\newline
      "    @BaseFont { Times Roman 11p }"  #\newline
      "}"                                  #\newline
      "@Document"                          #\newline
      "//"                                 #\newline
      "@Text @Begin"                       #\newline
      #\newline)))

#|edoc------------------------------------------------------------------

Write a prologue to an output file. This procedure will be called for
each output file generated by EDOC.

When stripping documentation (\k{-s} option) and emitting pure code,
a warning message of the form

\b{DO NOT EDIT THIS FILE! EDIT filename INSTEAD.}

will be placed in a comment at the top of the output file.

When the desired section has not yet been reached while extracting a
section (\k{-x}), do nothing. Otherwise print a Lout or HTML prologue,
depending on the \k{-L} option.

Finally, if a "prologue file" was specified on the command line
(\k{-P}), copy that file to the output file.

------------------------------------------------------------------code|#

(define (prologue lang)
  (cond
    ((opt-val strip-doc)
      (pr (if (eq? lang 'scheme)
              "; DO NOT EDIT THIS FILE!"
              "/* DO NOT EDIT THIS FILE!")
          (if *file-name*
              (string-append " EDIT \"" *file-name* "\" INSTEAD.")
              "")
          (if (eq? lang 'ccode) " */" "")
          #\newline))
    ((and (opt-val extract)
          (not *extracting*)))
    ((opt-val lout)
      (lout-prologue))
    (else
      (html-prologue)))
  (if (and (not (opt-val extract))
           (opt-val prologue-file))
      (copy-file (opt-val prologue-file))))

#|edoc------------------------------------------------------------------

Emit the HTML and Lout epilogues, respectively.

------------------------------------------------------------------code|#

(define (html-epilogue)
  (for-each
    pr
    '(""         #\newline
      ""  #\newline
      ""  #\newline)))

(define (lout-epilogue)
  (for-each
    pr
    '("@End @Text"  #\newline
      #\newline)))

#|edoc------------------------------------------------------------------

Write an epilogue to an output file. This procedure will be called for
each output file generated by EDOC. It will only be generated, if the
program does not run in extract mode (\k{-x}) or the section to extract
has been reached.

The epilogue consists of the content of an epilogue file (if \k{-E} was
specified) and the HTML or Lout epilogue, respectively.

When the desired section has been extracted in extract mode, the
\k{epilogue} procedure will end program execution after writing the
epilogue.

------------------------------------------------------------------code|#

(define (epilogue)
  (if (and (not (opt-val extract))
           (opt-val epilogue-file))
      (copy-file (opt-val epilogue-file)))
  (if (and (not (opt-val strip-doc))
           (or (not (opt-val extract))
               *extracting*))
      (if (opt-val lout)
          (lout-epilogue)
          (html-epilogue)))
  (if (opt-val extract)
      (if *extracting*
          (sys:exit)
          (set! *extracting* #t))))

#|edoc------------------------------------------------------------------

These are symbolic representation for all \e{modes} and \e{attributes}
of EDOC.

------------------------------------------------------------------code|#

(define mode-text    'text)
(define mode-quote   'quote)    ; \q
(define mode-block   'block)    ; \b
(define mode-ulist   'ulist)    ; \u
(define mode-olist   'olist)    ; \o
(define mode-hd0     'hd0)      ; \0
(define mode-hd1     'hd1)      ; \1
(define mode-hd2     'hd2)      ; \2
(define mode-hd3     'hd3)      ; \3
(define mode-image   'image)    ; \i
(define attr-literal 'literal)  ; \=
(define attr-anchor  'anchor)   ; \a
(define attr-ref     'ref)      ; \r
(define attr-var     'var)      ; \v
(define attr-keyword 'keyword)  ; \k
(define attr-emph    'emph)     ; \e
(define attr-strong  'strong)   ; \E
(define attr-highlt  'highlt)   ; \h
(define attr-elem    'element)  ; \l
(define attr-index   'index)    ; \x
(define attr-cindex  'cindex)   ; \X
(define attr-nindex  'nindex)   ; \n
(define attr-vindex  'vindex)   ; \V
(define attr-small   'small)    ; \s
(define attr-sub     'sub)      ; \_
(define attr-super   'super)    ; \^

#|edoc------------------------------------------------------------------

\k{Mode} is the current mode, \k{attr} is the current attribute. \k{#F}
means that no mode/attribute is currently in effect.

------------------------------------------------------------------code|#

(define mode #f)
(define attr #f)

#|edoc------------------------------------------------------------------

The \k{html-reset-attr!} and \k{lout-set-attr!} procedures terminate
the HTML and Lout notations used for rendering attributes. For example,
when the \k{\\k} (keyword) attribute is in effect (\k{attr} is set to
\k{attr-keyword}), then \k{html-reset-attr!} would output \k{}.

\k{Reset-attr!} uses either of the above to reset the current
attribute, depending on the output language selected, and sets \k{attr}
to \k{#f}.

------------------------------------------------------------------code|#

(define (html-reset-attr!)
  (cond ((eq? attr attr-elem)    (pr "
      2. "))
        ((eq? attr attr-emph)    (pr "      "))
        ((eq? attr attr-strong)  (pr ""))
        ((eq? attr attr-highlt)  (pr ""))
        ((eq? attr attr-keyword) (pr ""))
        ((eq? attr attr-anchor)  (pr "\">"))
        ((eq? attr attr-ref)     (pr ""))
        ((eq? attr attr-var)     (pr "      "))
        ((eq? attr attr-small)   (pr "      "))
        ((eq? attr attr-sub)     (pr ""))
        ((eq? attr attr-super)   (pr ""))
        ((eq? attr attr-index)   (pr ""))
        ((eq? attr attr-cindex)  (pr ""))
        ((eq? attr attr-vindex)  (pr ""))
        ((eq? attr attr-nindex)  (pr ""))))

(define (lout-reset-attr!)
  (cond ((eq? attr attr-elem)    (pr "} @Br"))
        ((eq? attr attr-emph)    (pr "}}"))
        ((eq? attr attr-strong)  (pr "}}"))
        ((eq? attr attr-highlt)  (pr "}}"))
        ((eq? attr attr-keyword) (pr "}}"))
        ((eq? attr attr-anchor)  (pr "}}"))
        ((eq? attr attr-ref)     (pr "}"))
        ((eq? attr attr-var)     (pr "}}"))
        ((eq? attr attr-small)   (pr "}}"))
        ((eq? attr attr-sub)     (pr "}}"))
        ((eq? attr attr-super)   (pr "}}"))
        ((eq? attr attr-index)   (pr "}}"))
        ((eq? attr attr-cindex)  (pr "}}}"))
        ((eq? attr attr-vindex)  (pr "}}}"))
        ((eq? attr attr-nindex)  (pr "}}"))))

(define (reset-attr!)
  (if (opt-val lout)
      (lout-reset-attr!)
      (html-reset-attr!))
  (set! attr #f))

#|edoc------------------------------------------------------------------

\k{Html-set-attr!} and \k{lout-set-attr!} print the corresponding HTML
or Lout command for rendering that attribute.

------------------------------------------------------------------code|#

(define (html-set-attr! x)
  (cond ((eq? x attr-elem)    (pr "
    2. "))
        ((eq? x attr-emph)    (pr ""))
        ((eq? x attr-strong)  (pr ""))
        ((eq? x attr-highlt)  (pr ""))
        ((eq? x attr-keyword) (pr ""))
        ((eq? x attr-anchor)  (pr ""))
        ((eq? x attr-small)   (pr ""))
        ((eq? x attr-sub)     (pr ""))
        ((eq? x attr-super)   (pr ""))
        ((eq? x attr-index)   (pr ""))
        ((eq? mode mode-olist) (pr "
    "))
        ((eq? mode mode-ulist) (pr "
"))
        ((eq? mode mode-hd0)   (pr ""))
        ((eq? mode mode-hd1)   (pr ""))
        ((eq? mode mode-hd2)   (pr ""))
        ((eq? mode mode-hd3)   (pr ""))
        ((eq? mode mode-image) (pr ".png\">"))
        ((eq? mode mode-quote) (pr "
")) ((eq? mode mode-text) (pr "

")))) (define (lout-reset-mode!) (cond ((eq? mode mode-block) (pr "}//" #\newline)) ((eq? mode mode-olist) (pr "}//" #\newline)) ((eq? mode mode-ulist) (pr "}//" #\newline)) ((eq? mode mode-hd0) (pr "}//" #\newline)) ((eq? mode mode-hd1) (pr "}//" #\newline)) ((eq? mode mode-hd2) (pr "}//" #\newline)) ((eq? mode mode-hd3) (pr "}//" #\newline)) ((eq? mode mode-image) (pr ".eps}}//")) ((eq? mode mode-quote) (pr "}//" #\newline)) ((eq? mode mode-text) (pr "}//" #\newline)))) #|edoc------------------------------------------------------------------ \k{Reset-mode!} resets a mode. When resetting part (\k{\\0}) mode with the backlink (\k{-b}) option active, it also prints the end-of-anchor tag of the back link. ------------------------------------------------------------------code|# (define (reset-mode!) (if (and (eq? mode mode-hd0) (opt-val backlink)) (pr "")) (if (opt-val lout) (lout-reset-mode!) (html-reset-mode!)) (set! mode #f)) #|edoc------------------------------------------------------------------ \k{Html-set-mode!}, \k{lout-set-mode!}, and \k{set-mode!} are like their counterparts for setting attributes, but they emit markup for beginning modes instead. ------------------------------------------------------------------code|# (define (html-set-mode! x) (cond ((eq? x mode-block) (pr "
"))
        ((eq? x mode-ulist) (pr "
" #\newline))) (close-ndx))) (epilogue)) ((string=? "" line) (loop (+ 1 nnl))) ((edoc-start? line) (set-language! (if (char=? #\# (string-ref line 0)) 'scheme 'ccode)) (cond ((edoc-end? line) (if (string-ci=? "reset" (substring line 7 12)) (set! *language* #f)) (loop 0)) (else (pr (gen 'terminate: attr 'lout-mode: (opt-val lout))) (set! attr '(#f #f #f 0 ())) (if (and cont (not (opt-val strip-doc))) (if (opt-val lout) (pr "}//" #\newline) (pr "" #\newline))) (set! cont #f) (if init (prologue *language*)) (set! init #f) (edoc) (loop 0)))) (else (if init (prologue *language*)) (set! init #f) (when (not cont) (cond ((opt-val strip-doc)) ((opt-val lout) (pr "@Code{")) (else (pr "
")))
                        (set! cont #t))
                  (cond ((opt-val strip-doc))
                        ((eq? *language* 'scheme)
                          (set! out (scm2html 'mark-s9-procs: #t
                                              'mark-s9-extns: #t
                                              'tilde-quotes: #t
                                              'input-string: line
                                              'initial-style: attr
                                              'lout-mode: (opt-val lout))))
                        ((eq? *language* 'ccode)
                          (set! out (c2html 'input-string: line
                                            'initial-style: attr
                                            'lout-mode: (opt-val lout))))
                        (else
                          (edoc-error "cannot figure out source language")))
                  (do ((i 0 (+ 1 i)))
                        ((= i nnl))
                    (pr #\newline))
                  (cond (out
                          (set! attr (car out))
                          (pr (cadr out) #\newline))
                        (else
                          (pr line #\newline)))
                  (loop 0))))))))

#|edoc------------------------------------------------------------------

Print command line usage.

------------------------------------------------------------------code|#

(define (usage)
  (display* "Usage: edoc [-iswL] [-b file] [-l lang] [-o file] [-t title]"
            " [-x name]"
            #\newline
            "            [-E file] [-P file] [file ...]"
            #\newline))

#|edoc------------------------------------------------------------------

\3{Main Program}

The main program parses the command line options using
\k{parse-options!}. It accepts the options defined at the beginning of
the program. It then initializes some global variables with option
values and opens an output file, it an \k{-o} option was given.

After that, there are three options. When \k{-h} was specified on the
command line, a long usage test prints and the program exits.

When no files where specified on the command line, input is taken from
the standard input port. Otherwise, input is redirected from each given
file in sequence.

The list of files (\v{files}) specified after all options on the
command line is returned by \k{parse-options!} after parsing.

------------------------------------------------------------------code|#

(let ((files (parse-options! (sys:command-line) options usage)))
  (if (opt-val language)
      (set! *language* (string->symbol (opt-val language))))
  (if (opt-val output-file)
      (next-output-file (opt-val output-file)))
  (if (opt-val title)
      (set! *title* (opt-val title)))
  (cond ((opt-val show-help)
          (display-usage
            `(""
              ,usage
              ""
              "Render programs with embedded edoc sections in HTML."
              ""
              "-b file  make headings links back to 'file'"
              "-i       generate index file (INDEX)"
              "-l lang  source language is lang (scheme, ccode)"
              "-o file  write output to the given file"
              "-s       strip edoc sections, output raw code"
              "-t text  content of the HTML TITLE tag"
              "-w       overwrite output files (default: keep)"
              "-x name  extract section with given file name"
              "-E file  insert epilogue 'file' at end of output"
              "-P file  insert prologue 'file' at beginning of output"
              "-L       generate Lout output (experimental!)"
              ""))
          (sys:exit 0))
        ((null? files)
          (code))
        (else
          (for-each (lambda (file)
                      (with-input-from-file
                        file
                        (lambda ()
                          (set! *file-name* file)
                          (code))))
                    files))))
s9/help/help000644 001751 001751 00000002200 13042074375 012623 0ustar00nmhnmh000000 000000 S9 LIB  (help)                     ==>  unspecific
        (help symbol | string)     ==>  unspecific
        (apropos)                  ==>  list
        (apropos symbol | string)  ==>  list

        (load-from-library "help.scm")

Display the synopsis of the given procedure or keyword. When
SYMBOL is described in R4RS, produce its R4RS entry, otherwise
display a S9FES-specific summary. When no argument is passed
to HELP, it explains itself.

APROPOS returns a list of all procedure names for which help
pages exist. When an argument is passed to APROPOS, its output
is limited to topics whose name contains the argument.

The *LINES-PER-PAGE* variable controls the number of lines
to be printed by HELP before prompting. Set to #F for continuous
printing.

(help 'symbol?)  ==>  unspecific

Output: R4RS 6.4  (symbol? object)  ==>  boolean

        Returns #T if OBJECT is a symbol, otherwise returns #F.

        (symbol? 'foo)          ==>  #t
        (symbol? (car '(a b)))  ==>  #t
        (symbol? "bar")         ==>  #f
        (symbol? 'nil)          ==>  #t
        (symbol? '())           ==>  #f
        (symbol? #f)            ==>  #f
s9/help/not000644 001751 001751 00000000414 11203550420 012463 0ustar00nmhnmh000000 000000 R4RS 6.1  (not object)  ==>  boolean

NOT returns #T if OBJECT is false, and returns #F otherwise.

(not #t)        ==>  #f
(not 3)         ==>  #f
(not (list 3))  ==>  #f
(not #f)        ==>  #t
(not '())       ==>  #f
(not (list))    ==>  #f
(not 'nil)      ==>  #f
s9/help/eqvp000644 001751 001751 00000011506 12033046611 012646 0ustar00nmhnmh000000 000000 R4RS 6.2  (eqv? object1 object2)  ==>  boolean

The EQV? procedure defines a useful equivalence relation on objects.
Briefly, it returns #T if OBJECT1 and OBJECT2 should normally be
regarded as the same object. This relation is left slightly open
to interpretation, but the following partial specification of EQV?
holds for all implementations of Scheme.

The EQV? procedure returns #T if:

- OBJECT1 and OBJECT2 are both #T or both #F.
- OBJECT1 and OBJECT2 are both symbols and
  (string=? (symbol->string OBJECT1)
            (symbol->string OBJECT2))  ==>  #t

Note: This assumes that neither OBJECT1 nor OBJECT2 is an "uninterned
symbol" as alluded to in section 6.4 Symbols. This report does not
presume to specify the behavior of EQV? on implementation-dependent
extensions.

- OBJECT1 and OBJECT2 are both numbers, are numerically equal
  (see =, section see section 6.5 Numbers), and are either both exact
  or both inexact.
- OBJECT1 and OBJECT2 are both characters and are the same
  character according to the char=? procedure (section see
  section 6.6 Characters).
- both OBJECT1 and OBJECT2 are the empty list.
- OBJECT1 and OBJECT2 are pairs, vectors, or strings that denote
  the same locations in the store (section see section 3.5 Storage
  model).
- OBJECT1 and OBJECT2 are procedures whose location tags are
  equal (section see section 4.1.4 lambda expressions).

The EQV? procedure returns #F if:

- one of OBJECT1 and OBJECT2 is an exact number but the other is an
  inexact number.
- OBJECT1 and OBJECT2 are of different types (section see section
  3.4 Disjointness of types).
- one of OBJECT1 and OBJECT2 is #T but the other is #F.
- OBJECT1 and OBJECT2 are symbols but
  (string=? (symbol->string OBJECT1)
            (symbol->string OBJECT2))  ==>  #f
- OBJECT1 and OBJECT2 are numbers for which the = procedure
  returns #F.
- OBJECT1 and OBJECT2 are characters for which the char=? procedure
  returns #F.
- one of OBJECT1 and OBJECT2 is the empty list but the other is not.
- OBJECT1 and OBJECT2 are pairs, vectors, or strings that denote
  distinct locations.
- OBJECT1 and OBJECT2 are procedures that would behave differently
  (return a different value or have different side effects)
  for some arguments.

(eqv? 'a 'a)                  ==>  #t
(eqv? 'a 'b)                  ==>  #f
(eqv? 2 2)                    ==>  #t
(eqv? '() '())                ==>  #t
(eqv? 100000000 100000000)    ==>  #t
(eqv? (cons 1 2) (cons 1 2))  ==>  #f
(eqv? (lambda () 1)
      (lambda () 2))          ==>  #f
(eqv? #f 'nil)                ==>  #f
(let ((p (lambda (x) x)))
  (eqv? p p))                 ==>  #t

The following examples illustrate cases in which the above rules
do not fully specify the behavior of EQV?. All that can be said
about such cases is that the value returned by EQV? must be a
boolean.

(eqv? "" "")           ==>  unspecified
(eqv? '#() '#())       ==>  unspecified
(eqv? (lambda (x) x)
      (lambda (x) x))  ==>  unspecified
(eqv? (lambda (x) x)
      (lambda (y) y))  ==>  unspecified

The next set of examples shows the use of EQV? with procedures that
have local state. Gen-counter must return a distinct procedure every
time, since each procedure has its own internal counter. Gen-loser,
however, returns equivalent procedures each time, since the local
state does not affect the value or side effects of the procedures.

(define (gen-counter)
  (let ((n 0))
    (lambda () (set! n (+ n 1)) n)))
(let ((g (gen-counter)))
  (eqv? g g))                         ==>  #t
  (eqv? (gen-counter) (gen-counter))  ==>  #f

(define (gen-loser)
  (let ((n 0))
    (lambda () (set! n (+ n 1)) 27)))
(let ((g (gen-loser)))
  (eqv? g g))                          ==>  #t
  (eqv? (gen-loser) (gen-loser))       ==>  unspecified

(letrec ((f (lambda () (if (eqv? f g) 'both 'f)))
         (g (lambda () (if (eqv? f g) 'both 'g)))
  (eqv? f g)))                                     ==>  unspecified

(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
         (g (lambda () (if (eqv? f g) 'g 'both)))
  (eqv? f g)))                                     ==>  #f

Since it is an error to modify constant objects (those returned by
literal expressions), implementations are permitted, though not
required, to share structure between constants where appropriate.
Thus the value of EQV? on constants is sometimes implementation-dependent.

(eqv? '(a) '(a))          ==>  unspecified
(eqv? "a" "a")            ==>  unspecified
(eqv? '(b) (cdr '(a b)))  ==>  unspecified
(let ((x '(a)))
  (eqv? x x))             ==>  #t

Rationale: The above definition of EQV? allows implementations
latitude in their treatment of procedures and literals: implementations
are free either to detect or to fail to detect that two procedures
or two literals are equivalent to each other, and can decide whether
or not to merge representations of equivalent objects by using the
same pointer or bit pattern to represent both.
s9/help/delete-file000644 001751 001751 00000000241 11203544622 014047 0ustar00nmhnmh000000 000000 S9fES  (delete-file string)  ==>  unspecific

Delete the file specifed in the STRING argument. If the file does
not exist or cannot be deleted, report an error.
s9/help/booleanp000644 001751 001751 00000000277 11203541663 013502 0ustar00nmhnmh000000 000000 R4RS 6.1  (boolean? object)  ==>  boolean

BOOLEAN? returns #T if OBJECT is either #T or #F and returns #F
otherwise.

(boolean? #f)   ==>  #t
(boolean? 0)    ==>  #f
(boolean? '())  ==>  #f
s9/help/eqp000644 001751 001751 00000003153 11203545167 012467 0ustar00nmhnmh000000 000000 R4RS 6.2  (eq? object1 object2)  ==>  boolean

EQ? is similar to EQV? except that in some cases it is capable of
discerning distinctions finer than those detectable by EQV?.

EQ? and EQV? are guaranteed to have the same behavior on symbols,
booleans, the empty list, pairs, and non-empty strings and vectors.
EQ?'s behavior on numbers and characters is implementation-dependent,
but it will always return either true or false, and will return
true only when EQV? would also return true. EQ? may also behave
differently from EQV? on empty vectors and empty strings.

(eq? 'a 'a)                ==>  #t
(eq? '(a) '(a))            ==>  unspecified
(eq? (list 'a) (list 'a))  ==>  #f
(eq? "a" "a")              ==>  unspecified
(eq? "" "")                ==>  unspecified
(eq? '() '())              ==>  #t
(eq? 2 2)                  ==>  unspecified
(eq? #\A #\A)              ==>  unspecified
(eq? car car)              ==>  #t
(let ((n (+ 2 3)))
  (eq? n n))               ==>  unspecified
(let ((x '(a)))
  (eq? x x))               ==>  #t
(let ((x '#()))
  (eq? x x))               ==>  #t
(let ((p (lambda (x) x)))
  (eq? p p))               ==>  #t

Rationale: It will usually be possible to implement EQ? much more
efficiently than EQV?, for example, as a simple pointer comparison
instead of as some more complicated operation. One reason is that it
may not be possible to compute EQV? of two numbers in constant time,
whereas EQ? implemented as pointer comparison will always finish in
constant time. EQ? may be used like EQV? in applications using
procedures to implement objects with state since it obeys the same
constraints as EQV?.
s9/help/equalp000644 001751 001751 00000001242 11203545172 013162 0ustar00nmhnmh000000 000000 R4RS 6.2  (equal? object1 object2)  ==>  boolean

EQUAL? recursively compares the contents of pairs, vectors, and
strings, applying eqv? on other objects such as numbers and symbols.
A rule of thumb is that objects are generally EQUAL? if they print
the same. EQUAL? may fail to terminate if its arguments are circular
data structures.

(equal? 'a 'a)               ==>  #t
(equal? '(a) '(a))           ==>  #t
(equal? '(a (b) c)
        '(a (b) c))          ==>  #t
(equal? "abc" "abc")         ==>  #t
(equal? 2 2)                 ==>  #t
(equal? (make-vector 5 'a)
        (make-vector 5 'a))  ==>  #t
(equal? (lambda (x) x)
        (lambda (y) y))      ==>  unspecified
s9/help/pairp000644 001751 001751 00000000321 11203550776 013011 0ustar00nmhnmh000000 000000 R4RS 6.3  (pair? object)  ==>  boolean

PAIR? returns #T if OBJECT is a pair, and otherwise returns #F.

(pair? '(a . b))  ==>  #t
(pair? '(a b c))  ==>  #t
(pair? '())       ==>  #f
(pair? '#(a b))   ==>  #f
s9/help/cons000644 001751 001751 00000000613 11203543435 012636 0ustar00nmhnmh000000 000000 R4RS 6.3  (cons object1 object2)  ==>  pair

Returns a newly allocated pair whose car is OBJECT1 and whose cdr
is OBJECT2. The pair is guaranteed to be different (in the sense
of EQV?) from every existing object.

(cons 'a '())         ==>  (a)
(cons '(a) '(b c d))  ==>  ((a) b c d)
(cons "a" '(b c))     ==>  ("a" b c)
(cons 'a 3)           ==>  (a . 3)
(cons '(a b) 'c)      ==>  ((a b) . c)
s9/help/car000644 001751 001751 00000000401 11203542061 012426 0ustar00nmhnmh000000 000000 R4RS 6.3  (car pair)  ==>  object

Returns the contents of the car field of PAIR. Note that it is an
error to take the car of the empty list.

(car '(a b c))      ==>  a
(car '((a) b c d))  ==>  (a)
(car '(1 . 2))      ==>  1
(car '())           ==>  error
s9/help/cdr000644 001751 001751 00000000352 11203542623 012442 0ustar00nmhnmh000000 000000 R4RS 6.3  (cdr pair)  ==>  object

Returns the contents of the cdr field of PAIR. Note that it is an
error to take the cdr of the empty list.

(cdr '((a) b c d))  ==>  (b c d)
(cdr '(1 . 2))      ==>  2
(cdr '())           ==>  error
s9/help/set-carb000644 001751 001751 00000000423 11203551407 013371 0ustar00nmhnmh000000 000000 R4RS 6.3  (set-car! pair object)  ==>  unspecific

Stores OBJECT in the car field of PAIR. The value returned by
SET-CAR! is unspecified.

(define (f) (list 'not-a-constant-list))
(define (g) '(constant-list))

(set-car! (f) 3)  ==>  unspecified
(set-car! (g) 3)  ==>  error
s9/help/set-cdrb000644 001751 001751 00000000423 11203551437 013377 0ustar00nmhnmh000000 000000 R4RS 6.3  (set-cdr! pair object)  ==>  unspecific

Stores OBJECT in the cdr field of PAIR. The value returned by
SET-CDR! is unspecified.

(define (f) (list 'not-a-constant-list))
(define (g) '(constant-list))

(set-cdr! (f) 3)  ==>  unspecified
(set-cdr! (g) 3)  ==>  error
s9/help/caar000644 001751 001751 00000000625 11203541716 012605 0ustar00nmhnmh000000 000000 R4RS 6.3  (caar pair)    ==>  object
          (cadr pair)    ==>  object
          ...
          (cdddar pair)  ==>  object
          (cddddr pair)  ==>  object

These procedures are compositions of car and cdr, where for example
caddr could be defined by

(define (caddr x) (car (cdr (cdr x)))).

Arbitrary compositions, up to four deep, are provided. There are
twenty-eight of these procedures in all.
s9/help/cadr000755 001751 001751 00000000000 13042075333 013427 2caarustar00nmhnmh000000 000000 s9/help/cdar000755 001751 001751 00000000000 13042075333 013427 2caarustar00nmhnmh000000 000000 s9/help/cddr000755 001751 001751 00000000000 13042075333 013432 2caarustar00nmhnmh000000 000000 s9/help/caadr000755 001751 001751 00000000000 13042075333 013570 2caarustar00nmhnmh000000 000000 s9/help/cadar000755 001751 001751 00000000000 13042075333 013570 2caarustar00nmhnmh000000 000000 s9/help/caddr000755 001751 001751 00000000000 13042075333 013573 2caarustar00nmhnmh000000 000000 s9/help/cdaar000755 001751 001751 00000000000 13042075333 013570 2caarustar00nmhnmh000000 000000 s9/help/cdadr000755 001751 001751 00000000000 13042075333 013573 2caarustar00nmhnmh000000 000000 s9/help/cddar000755 001751 001751 00000000000 13042075333 013573 2caarustar00nmhnmh000000 000000 s9/help/cdddr000755 001751 001751 00000000000 13042075333 013576 2caarustar00nmhnmh000000 000000 s9/help/cdddar000755 001751 001751 00000000000 13042075333 013737 2caarustar00nmhnmh000000 000000 s9/help/caaadr000755 001751 001751 00000000000 13042075333 013731 2caarustar00nmhnmh000000 000000 s9/help/caadar000755 001751 001751 00000000000 13042075333 013731 2caarustar00nmhnmh000000 000000 s9/help/caaddr000755 001751 001751 00000000000 13042075333 013734 2caarustar00nmhnmh000000 000000 s9/help/cadaar000755 001751 001751 00000000000 13042075333 013731 2caarustar00nmhnmh000000 000000 s9/help/char-numericp000755 001751 001751 00000000000 13042075333 017534 2char-alphabeticpustar00nmhnmh000000 000000 s9/help/cadadr000755 001751 001751 00000000000 13042075333 013734 2caarustar00nmhnmh000000 000000 s9/help/caddar000755 001751 001751 00000000000 13042075333 013734 2caarustar00nmhnmh000000 000000 s9/help/cadddr000755 001751 001751 00000000000 13042075333 013737 2caarustar00nmhnmh000000 000000 s9/help/cdaaar000755 001751 001751 00000000000 13042075333 013731 2caarustar00nmhnmh000000 000000 s9/help/cdaadr000755 001751 001751 00000000000 13042075333 013734 2caarustar00nmhnmh000000 000000 s9/help/cdadar000755 001751 001751 00000000000 13042075333 013734 2caarustar00nmhnmh000000 000000 s9/help/cdaddr000755 001751 001751 00000000000 13042075333 013737 2caarustar00nmhnmh000000 000000 s9/help/cddaar000755 001751 001751 00000000000 13042075333 013734 2caarustar00nmhnmh000000 000000 s9/help/cddadr000755 001751 001751 00000000000 13042075333 013737 2caarustar00nmhnmh000000 000000 s9/help/cddddr000755 001751 001751 00000000000 13042075333 013742 2caarustar00nmhnmh000000 000000 s9/help/nullp000644 001751 001751 00000000146 11203550435 013025 0ustar00nmhnmh000000 000000 R4RS 6.3  (null? object)  ==>  boolean

Returns #T if OBJECT is the empty list, otherwise returns #F.
s9/help/listp000644 001751 001751 00000000517 11203547276 013041 0ustar00nmhnmh000000 000000 R4RS 6.3  (list? object)  ==>  boolean

Returns #T if OBJECT is a list, otherwise returns #F. By definition,
all lists have finite length and are terminated by the empty list.

(list? '(a b c))      ==>  #t
(list? '())           ==>  #t
(list? '(a . b))      ==>  #f
(let ((x (list 'a)))
  (set-cdr! x x)
  (list? x))          ==>  #f
s9/help/list000644 001751 001751 00000000233 11203547075 012651 0ustar00nmhnmh000000 000000 R4RS 6.3  (list object ...)  ==>  list

Returns a newly allocated list of its arguments.

(list 'a (+ 3 4) 'c)  ==>  (a 7 c)
(list)                ==>  ()
s9/help/append000644 001751 001751 00000001155 11203474303 013142 0ustar00nmhnmh000000 000000 R4RS 6.3  (append list ...)         ==>  list
          (append list ... object)  ==>  object

Returns a list consisting of the elements of the first list followed
by the elements of the other lists.

(append '(x) '(y))        ==>  (x y)
(append '(a) '(b c d))    ==>  (a b c d)
(append '(a (b)) '((c)))  ==>  (a (b) (c))

The resulting list is always newly allocated, except that it shares
structure with the last list argument. The last argument may actually
be any object; an improper list results if the last argument is not
a proper list.

(append '(a b) '(c . d))  ==>  (a b c . d)
(append '() 'a)           ==>  a
s9/help/length000644 001751 001751 00000000252 11203546674 013164 0ustar00nmhnmh000000 000000 R4RS 6.3  (length list)  ==>  integer

Returns the length of list.

(length '(a b c))          ==>  3
(length '(a (b) (c d e)))  ==>  3
(length '())               ==>  0
s9/help/reverse000644 001751 001751 00000000340 11203551370 013341 0ustar00nmhnmh000000 000000 R4RS 6.3  (reverse list)  ==>  list

Returns a newly allocated list consisting of the elements of LIST
in reverse order.

(reverse '(a b c))              ==>  (c b a)
(reverse '(a (b c) d (e (f))))  ==>  ((e (f)) d (b c) a)
s9/help/list-tail000644 001751 001751 00000000357 11431711100 013570 0ustar00nmhnmh000000 000000 R4RS 6.3  (list-tail list integer)  ==>  list

Returns the sublist of LIST obtained by omitting the first INTEGER
elements. LIST-TAIL could be defined by

(define (list-tail x k)
  (if (zero? k)
      x
      (list-tail (cdr x) (- k 1))))
s9/help/list-ref000644 001751 001751 00000000261 11431711075 013420 0ustar00nmhnmh000000 000000 R4RS 6.3  (list-ref list integer)  ==>  obj

Returns the INTEGER'th element of list. (This is the same as the
car of (list-tail list INTEGER).)

(list-ref '(a b c d) 2)  ==>  c
s9/help/memq000644 001751 001751 00000001456 11203550006 012631 0ustar00nmhnmh000000 000000 R4RS 6.3  (memq object list)    ==>  list | #f
          (memv object list)    ==>  list | #f
          (member object list)  ==>  list | #f

These procedures return the first sublist of LIST whose car is
OBJECT, where the sublists of LIST are the non-empty lists returned
by (list-tail list k) for K less than the length of LIST. If OBJECT
does not occur in LIST, then #F (not the empty list) is returned.
MEMQ uses EQ? to compare OBJECT with the elements of LIST, while
MEMV uses EQV? and MEMBER uses EQUAL?.

(memq 'a '(a b c))             ==>  (a b c)
(memq 'b '(a b c))             ==>  (b c)
(memq 'a '(b c d))             ==>  #f
(memq (list 'a) '(b (a) c))    ==>  #f
(member (list 'a) '(b (a) c))  ==>  ((a) c)
(memq 101 '(100 101 102))      ==>  unspecified
(memv 101 '(100 101 102))      ==>  (101 102)
s9/help/memv000755 001751 001751 00000000000 13042075333 013513 2memqustar00nmhnmh000000 000000 s9/help/member000755 001751 001751 00000000000 13042075333 014016 2memqustar00nmhnmh000000 000000 s9/help/assq000644 001751 001751 00000002106 11203554717 012647 0ustar00nmhnmh000000 000000 R4RS 6.3  (assq object alist)   ==>  pair | #f
          (assv object alist)   ==>  pair | #f
          (assoc object alist)  ==>  pair | #f

ALIST (for "association list") must be a list of pairs. These
procedures find the first pair in ALIST whose car field is OBJECT,
and returns that pair. If no pair in ALIST has OBJECT as its car,
then #F (not the empty list) is returned. ASSQ uses EQ? to compare
OBJECT with the car fields of the pairs in ALIST, while ASSV uses
EQV? and ASSOC uses EQUAL?.

(define e '((a 1) (b 2) (c 3)))
(assq 'a e)                             ==>  (a 1)
(assq 'b e)                             ==>  (b 2)
(assq 'd e)                             ==>  #f
(assq (list 'a) '(((a)) ((b)) ((c))))   ==>  #f
(assoc (list 'a) '(((a)) ((b)) ((c))))  ==>  ((a))
(assq 5 '((2 3) (5 7) (11 13)))         ==>  unspecified
(assv 5 '((2 3) (5 7) (11 13)))         ==>  (5 7)

Rationale: Although they are ordinarily used as predicates, MEMQ,
MEMV, MEMBER, ASSQ, ASSV, and ASSOC do not have question marks in
their names because they return useful values rather than just #T
or #F.
s9/help/assv000755 001751 001751 00000000000 13042075333 013533 2assqustar00nmhnmh000000 000000 s9/help/symbolp000644 001751 001751 00000000443 11203553015 013355 0ustar00nmhnmh000000 000000 R4RS 6.4  (symbol? object)  ==>  boolean

Returns #T if OBJECT is a symbol, otherwise returns #F.

(symbol? 'foo)          ==>  #t
(symbol? (car '(a b)))  ==>  #t
(symbol? "bar")         ==>  #f
(symbol? 'nil)          ==>  #t
(symbol? '())           ==>  #f
(symbol? #f)            ==>  #f
s9/help/symbol-to-string000644 001751 001751 00000001751 11203552737 015136 0ustar00nmhnmh000000 000000 R4RS 6.4  (symbol->string symbol)  ==>  string

Returns the name of SYMBOL as a string. If the symbol was part of
an object returned as the value of a literal expression (section
see section 4.1.2 Literal expressions) or by a call to the READ
procedure, and its name contains alphabetic characters, then the
string returned will contain characters in the implementation's
preferred standard case--some implementations will prefer upper
case, others lower case. If the symbol was returned by STRING->SYMBOL,
the case of characters in the string returned will be the same as
the case in the string that was passed to STRING->SYMBOL. It is an
error to apply mutation procedures like STRING-SET! to strings
returned by this procedure.

The following examples assume that the implementation's standard
case is lower case:

(symbol->string 'flying-fish)                ==>  "flying-fish"
(symbol->string 'Martin)                     ==>  "martin"
(symbol->string (string->symbol "Malvina"))  ==>  "Malvina"
s9/help/string-to-symbol000644 001751 001751 00000001602 11203552605 015123 0ustar00nmhnmh000000 000000 R4RS 6.4  (string->symbol string)  ==>  symbol

Returns the symbol whose name is STRING. This procedure can create
symbols with names containing special characters or letters in the
non-standard case, but it is usually a bad idea to create such
symbols because in some implementations of Scheme they cannot be
read as themselves. See SYMBOL->STRING.

The following examples assume that the implementation's standard
case is lower case:

(eq? 'mISSISSIppi 'mississippi)                    ==>  #t
(string->symbol "mISSISSIppi")                     ==>  the symbol with
                                                        name "mISSISSIppi"
(eq? 'bitBlt (string->symbol "bitBlt"))            ==>  #f
(eq? 'JollyWog
     (string->symbol (symbol->string 'JollyWog)))  ==>  #t

(string=? (symbol->string (string->symbol "K. Harper, M.D."))
          "K. Harper, M.D."                        ==>  #t
s9/help/numberp000644 001751 001751 00000001440 11430005040 013326 0ustar00nmhnmh000000 000000 R4RS 6.5.5  (integer? object)  ==>  boolean
            (number? object)   ==>  boolean
            (real? object)     ==>  boolean

These numerical type predicates can be applied to any kind of
argument, including non-numbers. They return #t if the object is
of the named type, and otherwise they return #f. In general, if a
type predicate is true of a number then all higher type predicates
are also true of that number. Consequently, if a type predicate is
false of a number, then all lower type predicates are also false
of that number.

(real? 3)          ==>  #t
(real? -2.5)       ==>  #t
(real? #e1e10)     ==>  #t
(integer? 3)       ==>  #t
(integer? 3.0)     ==>  #t

Note: The behavior of these type predicates on inexact numbers is
unreliable, since any inaccuracy may affect the result.
s9/help/eq000644 001751 001751 00000001512 12033046527 012302 0ustar00nmhnmh000000 000000 R4RS 6.5.5  (= number1 number2 ...)   ==>  boolean
            (< number1 number2 ...)   ==>  boolean
            (> number1 number2 ...)   ==>  boolean
            (<= number1 number2 ...)  ==>  boolean
            (>= number1 number2 ...)  ==>  boolean

These procedures return #T if their arguments are (respectively):
equal, monotonically increasing, monotonically decreasing, monotonically
nondecreasing, or monotonically non-increasing.

These predicates are required to be transitive.

Note: The traditional implementations of these predicates in Lisp-like
languages are not transitive. 

Note: While it is not an error to compare inexact numbers using
these predicates, the results may be unreliable because a small
inaccuracy may affect the result; this is especially true of = and
ZERO?. When in doubt, consult a numerical analyst.
s9/help/lt000755 001751 001751 00000000000 13042075333 012634 2equstar00nmhnmh000000 000000 s9/help/bitwise-and-c1000755 001751 001751 00000000000 13042075333 016525 2bitwise-andustar00nmhnmh000000 000000 s9/help/gt000755 001751 001751 00000000000 13042075333 012627 2equstar00nmhnmh000000 000000 s9/help/le000755 001751 001751 00000000000 13042075333 012615 2equstar00nmhnmh000000 000000 s9/help/ge000755 001751 001751 00000000000 13042075333 012610 2equstar00nmhnmh000000 000000 s9/help/zerop000644 001751 001751 00000000541 11430004470 013024 0ustar00nmhnmh000000 000000 R4RS 6.5.5  (zero? number)      ==>  boolean
            (positive? number)  ==>  boolean
            (negative? number)  ==>  boolean
            (odd? integer)      ==>  boolean
            (even? integer)     ==>  boolean

These numerical predicates test a number for a particular property,
returning #T or #F.

See also: note 2 in description of =.
s9/help/positivep000755 001751 001751 00000000000 13042075333 014771 2zeropustar00nmhnmh000000 000000 s9/help/negativep000755 001751 001751 00000000000 13042075333 014731 2zeropustar00nmhnmh000000 000000 s9/help/oddp000755 001751 001751 00000000000 13042075333 013675 2zeropustar00nmhnmh000000 000000 s9/help/evenp000755 001751 001751 00000000000 13042075333 014064 2zeropustar00nmhnmh000000 000000 s9/help/max000644 001751 001751 00000000444 11431711160 012456 0ustar00nmhnmh000000 000000 R4RS 6.5.5  (max number ...)  ==>  number
            (min number ...)  ==>  number

These procedures return the maximum or minimum of their arguments.

(max 3 4)      ==>  4   ; exact
(min 3 4.1)    ==>  3.0 ; inexact

Note: If any argument is inexact, then the result will also be
inexact.
s9/help/min000755 001751 001751 00000000000 13042075333 013160 2maxustar00nmhnmh000000 000000 s9/help/plus000644 001751 001751 00000000465 11212246153 012661 0ustar00nmhnmh000000 000000 R4RS 6.5.5  (+ number1 ...)  ==>  number
            (+)              ==>  number
            (* number1 ...)  ==>  number
            (*)              ==>  number

These procedures return the sum or product of their arguments.

(+ 3 4)  ==>  7
(+ 3)    ==>  3
(+)      ==>  0
(* 4)    ==>  4
(*)      ==>  1
s9/help/letstar000644 001751 001751 00000001124 11775333272 013362 0ustar00nmhnmh000000 000000 R4RS 4.2.2  (let*  )  ==>  object

Syntax:  should have the form

(( ) ...),

and  should be a sequence of one or more expressions.

Semantics: LET* is similar to LET, but the bindings are performed
sequentially from left to right, and the region of a binding indicated
by `( )' is that part of the LET* expression to the
right of the binding. Thus the second binding is done in an environment
in which the first binding is visible, and so on.

(let ((x 2) (y 3))
  (let* ((x 7)
         (z (+ x y)))
    (* z x)))          ==>  70
s9/help/minus000644 001751 001751 00000000624 11430006274 013026 0ustar00nmhnmh000000 000000 R4RS 6.5.5  (- number ...)  ==>  number
            (/ number ...)  ==>  number

With two or more arguments, these procedures return the difference
or quotient of their arguments, associating to the left. With one
argument, however, they return the additive or multiplicative inverse
of their argument.

(- 3 4)    ==>  -1
(- 3 4 5)  ==>  -6
(- 3)      ==>  -3
(/ 3 4 5)  ==>  0.15
(/ 4)      ==>  0.25

s9/help/abs000644 001751 001751 00000000144 11212244666 012444 0ustar00nmhnmh000000 000000 R4RS 6.5.5  (abs number)  ==>  number

ABS returns the magnitude of its argument.

(abs -7)  ==>  7
s9/help/quotient000644 001751 001751 00000001767 11430006377 013560 0ustar00nmhnmh000000 000000 R4RS 6.5.5  (quotient integer1 integer2)   ==>  integer
            (remainder integer1 integer2)  ==>  integer
            (modulo integer1 integer2)     ==>  integer

These procedures implement number-theoretic (integer) division: For
positive integers n1 and n2, if n3 and n4 are integers such that
n1=n2*n3+n4 and 0<=n4  n3
(remainder n1 n2)  ==>  n4
(modulo n1 n2)     ==>  n4

For integers n1 and n2 with n2 not equal to 0,

(= n1 (+ (* n2 (quotient n1 n2))
         (remainder n1 n2)))      ==>  #t.

The value returned by QUOTIENT always has the sign of the product
of its arguments. REMAINDER and MODULO differ on negative arguments--the
remainder is either zero or has the sign of the dividend, while the
modulo always has the sign of the divisor:

(modulo 13 4)       ==>  1
(remainder 13 4)    ==>  1

(modulo -13 4)      ==>  3
(remainder -13 4)   ==>  -1

(modulo 13 -4)      ==>  -3
(remainder 13 -4)   ==>  1

(modulo -13 -4)     ==>  -1
(remainder -13 -4)  ==>  -1
s9/help/remainder000755 001751 001751 00000000000 13042075333 015426 2quotientustar00nmhnmh000000 000000 s9/help/modulo000755 001751 001751 00000000000 13042075333 014757 2quotientustar00nmhnmh000000 000000 s9/help/gcd000644 001751 001751 00000000464 11775333033 012442 0ustar00nmhnmh000000 000000 R4RS 6.5.5  (gcd integer ...)  ==>  integer
            (lcm integer ...)  ==>  integer

These procedures return the greatest common divisor or least common
multiple of their arguments. The result is always non-negative.

(gcd 32 -36)  ==>  4
(gcd)         ==>  0
(lcm 32 -36)  ==>  288
(lcm)         ==>  1
s9/help/lcm000755 001751 001751 00000000000 13042075333 013120 2gcdustar00nmhnmh000000 000000 s9/help/expt000644 001751 001751 00000000207 11430005155 012645 0ustar00nmhnmh000000 000000 R4RS 6.5.5  (expt number1 number2)  ==>  number

Returns NUMBER1 raised to the power NUMBER2.

(Expt 0 0) is defined to be equal to 1.
s9/help/number-to-string000644 001751 001751 00000001760 12033047072 015112 0ustar00nmhnmh000000 000000 R4RS 6.5.6  (number->string number)          ==>  string
            (number->string number integer)  ==>  string

INTEGER must be a radix of either 2, 8, 10, or 16. If omitted, it
defaults to 10. The procedure NUMBER->STRING takes a number and a
radix and returns as a string an external representation of the
given number in the given radix such that

(let ((number number)
      (radix radix))
  (eqv? number
        (string->number (number->string number radix)
                        radix)))

is true. It is an error if no possible result makes this expression
true.

If NUMBER is inexact, the radix is 10, and the above expression can
be satisfied by a result that contains a decimal point, then the
result contains a decimal point and is expressed using the minimum
number of digits (exclusive of exponent and trailing zeros) needed
to make the above expression true; otherwise the format of the result
is unspecified.

The result returned by NUMBER->STRING never contains an explicit
radix prefix.
s9/help/string-to-number000644 001751 001751 00000001614 11431711270 015107 0ustar00nmhnmh000000 000000 R4RS 6.5.6  (string->number string)          ==>  integer
            (string->number string integer)  ==>  integer

Returns a number of the maximally precise representation expressed
by the given STRING. INTEGER must be an exact integer, either 2, 8,
10, or 16. If supplied, INTEGER is a default radix that may be
overridden by an explicit radix prefix in string (e.g. "#o177").
If INTEGER is not supplied, then the default radix is 10. If STRING
is not a syntactically valid notation for a number, then STRING->NUMBER
returns #F.

(string->number "100")     ==>  100
(string->number "100" 16)  ==>  256
(string->number "1e2")     ==>  100.0
(string->number "1.23")    ==>  1.23
(string->number "#i10")    ==>  10.0

The S9fES implementation supports base prefixes. It also supports
decimal points, exponent markers, unspecific digits (#), and
exact/inexact prefixes, if real number support is compiled in.
s9/help/charp000644 001751 001751 00000000143 11203543240 012761 0ustar00nmhnmh000000 000000 R4RS 6.6  (char? object)  ==>  boolean

Returns #T if OBJECT is a character, otherwise returns #F.
s9/help/charltp000755 001751 001751 00000000000 13042075333 014670 2chareqpustar00nmhnmh000000 000000 s9/help/chareqp000644 001751 001751 00000001653 11203543212 013315 0ustar00nmhnmh000000 000000 R4RS 6.6  (char=? char1 char2)   ==>  boolean
          (char  boolean
          (char>? char1 char2)   ==>  boolean
          (char<=? char1 char2)  ==>  boolean
          (char>=? char1 char2)  ==>  boolean

These procedures impose a total ordering on the set of characters.
It is guaranteed that under this ordering:

- The upper case characters are in order.
  For example, (char #t.
- The lower case characters are in order.
  For example, (char #t.
- The digits are in order.
  For example, (char #t.
- Either all the digits precede all the
  upper case letters, or vice versa.
- Either all the digits precede all the
  lower case letters, or vice versa.

Some implementations may generalize these procedures to take more
than two arguments, as with the corresponding numerical predicates.

The S9fES versions of these procedures do accept more than two
arguments.
s9/help/chargtp000755 001751 001751 00000000000 13042075333 014663 2chareqpustar00nmhnmh000000 000000 s9/help/charlep000755 001751 001751 00000000000 13042075333 014651 2chareqpustar00nmhnmh000000 000000 s9/help/chargep000755 001751 001751 00000000000 13042075333 014644 2chareqpustar00nmhnmh000000 000000 s9/help/char-cieqp000644 001751 001751 00000001144 11203542727 013713 0ustar00nmhnmh000000 000000 R4RS 6.6  (char-ci=? char1 char2)   ==>  boolean
          (char-ci  boolean
          (char-ci>? char1 char2)   ==>  boolean
          (char-ci<=? char1 char2)  ==>  boolean
          (char-ci>=? char1 char2)  ==>  boolean

These procedures are similar to CHAR=? et cetera, but they treat
upper case and lower case letters as the same. For example,

(char-ci=? #\A #\a)  ==>  #t.

Some implementations may generalize these procedures to take more
than two arguments, as with the corresponding numerical predicates.

The S9fES versions of these procedures do accept more than two
arguments.
s9/help/char-ciltp000755 001751 001751 00000000000 13042075333 015652 2char-cieqpustar00nmhnmh000000 000000 s9/help/stringp000644 001751 001751 00000000142 11203552773 013364 0ustar00nmhnmh000000 000000 R4RS 6.7  (string? object)  ==>  boolean

Returns #T if OBJECT is a string, otherwise returns #F.
s9/help/htmlify-string000755 001751 001751 00000000000 13042075333 017157 2htmlify-charustar00nmhnmh000000 000000 s9/help/char-alphabeticp000644 001751 001751 00000001301 11212245002 015043 0ustar00nmhnmh000000 000000 R4RS 6.6  (char-alphabetic? char)  ==>  boolean
          (char-numeric? char)     ==>  boolean
          (char-whitespace? char)  ==>  boolean
          (char-upper-case? char)  ==>  boolean
          (char-lower-case? char)  ==>  boolean

These procedures return #T if their arguments are alphabetic,
numeric, whitespace, upper case, or lower case characters, respectively,
otherwise they return #F. The following remarks, which are specific
to the ASCII character set, are intended only as a guide: The
alphabetic characters are the 52 upper and lower case letters. The
numeric characters are the ten decimal digits. The whitespace
characters are space, tab, line feed, form feed, and carriage return.
s9/help/hash-table-length000755 001751 001751 00000000000 13042075333 020022 2make-hash-tableustar00nmhnmh000000 000000 s9/help/queue-emptyp000755 001751 001751 00000000000 13042075333 015374 2queueustar00nmhnmh000000 000000 s9/help/r4rs-syntax-objects000755 001751 001751 00000000000 13042075333 020520 2r4rs-proceduresustar00nmhnmh000000 000000 s9/help/s9fes-syntax-objects000755 001751 001751 00000000000 13042075333 020657 2r4rs-proceduresustar00nmhnmh000000 000000 s9/help/char-to-integer000644 001751 001751 00000001324 11431711057 014664 0ustar00nmhnmh000000 000000 R4RS 6.6  (char->integer char)     ==>  integer
          (integer->char integer)  ==>  char

Given a character, CHAR->INTEGER returns an integer representation
of the character. Given an integer that is the image of a character
under CHAR->INTEGER, INTEGER->CHAR returns that character. These
procedures implement injective order isomorphisms between the set
of characters under the CHAR<=? ordering and some subset of the
integers under the <= ordering. That is, if

     (char<=? a b)  ==>  #t
and  (<= x y)       ==>  #t

and X and Y are in the domain of INTEGER->CHAR, then

     (<= (char->integer a)
         (char->integer b))       ==>  #t
and  (char<=? (integer->char x)
              (integer->char y))  ==>  #t.
s9/help/s9fes-procedures000755 001751 001751 00000000000 13042075333 020055 2r4rs-proceduresustar00nmhnmh000000 000000 s9/help/caaar000755 001751 001751 00000000000 13042075333 013565 2caarustar00nmhnmh000000 000000 s9/help/char-upcase000644 001751 001751 00000000454 11203543010 014057 0ustar00nmhnmh000000 000000 R4RS 6.6  (char-upcase char)    ==>  char
          (char-downcase char)  ==>  char

These procedures return a character CHAR2 such that

(char-ci=? char char2)  ==>  #t.

In addition, if CHAR is alphabetic, then the result of CHAR-UPCASE
is upper case and the result of CHAR-DOWNCASE is lower case.
s9/help/make-string000644 001751 001751 00000000446 11431711103 014111 0ustar00nmhnmh000000 000000 R4RS 6.7  (make-string integer)       ==>  string
          (make-string integer char)  ==>  string

MAKE-STRING returns a newly allocated string of length INTEGER.
If CHAR is given, then all elements of the string are initialized
to CHAR, otherwise the contents of the string are unspecified.
s9/help/string000644 001751 001751 00000000146 11203551717 013205 0ustar00nmhnmh000000 000000 R4RS 6.7  (string char ...)  ==>  string

Returns a newly allocated string composed of the arguments.
s9/help/string-length000644 001751 001751 00000000146 11203552075 014462 0ustar00nmhnmh000000 000000 R4RS 6.7  (string-length string)  ==>  integer

Returns the number of characters in the given string.
s9/help/string-ref000644 001751 001751 00000000271 11431711112 013744 0ustar00nmhnmh000000 000000 R4RS 6.7  (string-ref string integer)  ==>  char

INTEGER must be a valid index of STRING. STRING-REF returns character
at the INTEGER'th position of STRING using zero-origin indexing.
s9/help/string-setb000644 001751 001751 00000000704 11431711115 014131 0ustar00nmhnmh000000 000000 R4RS 6.7  (string-set! string integer char)  ==>  unspecific

INTEGER must be a valid index of STRING. STRING-SET! stores CHAR
in the element at the INTEGER'th position of STRING and returns an
unspecified value.

(define (f) (make-string 3 #\*))
(define (g) "***")
(string-set! (f) 0 #\?)                          ==>  unspecified
(string-set! (g) 0 #\?)                          ==>  error
(string-set! (symbol->string 'immutable) 0 #\?)  ==>  error
s9/help/stringeqp000644 001751 001751 00000000605 11203551746 013715 0ustar00nmhnmh000000 000000 R4RS 6.7  (string=? string1 string2)     ==>  boolean
          (string-ci=? string1 string2)  ==>  boolean

Returns #T if the two strings are the same length and contain the
same characters in the same positions, otherwise returns #F.
STRING-CI=? treats upper and lower case letters as though they were
the same character, but STRING=? treats upper and lower case as
distinct characters.
s9/help/string-cieqp000755 001751 001751 00000000000 13042075333 016231 2stringeqpustar00nmhnmh000000 000000 s9/help/stringlep000755 001751 001751 00000000000 13042075333 015645 2stringltpustar00nmhnmh000000 000000 s9/help/stringltp000644 001751 001751 00000002056 11203552027 013722 0ustar00nmhnmh000000 000000 R4RS 6.7  (string  boolean
          (string>? string1 string2)      ==>  boolean
          (string<=? string1 string2)     ==>  boolean
          (string>=? string1 string2)     ==>  boolean
          (string-ci  boolean
          (string-ci>? string1 string2)   ==>  boolean
          (string-ci<=? string1 string2)  ==>  boolean
          (string-ci>=? string1 string2)  ==>  boolean

These procedures are the lexicographic extensions to strings of
the corresponding orderings on characters. For example, STRING  string

STRING must be a string, and INTEGER-0 and INTEGER-N must satisfy

0 <= INTEGER-0 <= INTEGER-N <= (string-length string).

SUBSTRING returns a newly allocated string formed from the characters
of STRING beginning with index INTEGER-0 (inclusive) and ending with
index INTEGER-N (exclusive).
s9/help/string-append000644 001751 001751 00000000222 11203551730 014440 0ustar00nmhnmh000000 000000 R4RS 6.7  (string-append string ...)  ==>  string

Returns a newly allocated string whose characters form the
concatenation of the given strings.
s9/help/string-to-list000644 001751 001751 00000000534 11203547234 014576 0ustar00nmhnmh000000 000000 R4RS 6.7  (string->list string)  ==>  list
          (list->string chars)   ==>  string

STRING->LIST returns a newly allocated list of the characters that
make up the given string. LIST->STRING returns a newly allocated
string formed from the characters in the list CHARS. STRING->LIST
and LIST->STRING are inverses so far as EQUAL? is concerned.
s9/help/string-copy000644 001751 001751 00000000141 11203552051 014140 0ustar00nmhnmh000000 000000 R4RS 6.7  (string-copy string)  ==>  string

Returns a newly allocated copy of the given string.
s9/help/string-fillb000644 001751 001751 00000000212 11203552066 014263 0ustar00nmhnmh000000 000000 R4RS 6.7  (string-fill! string char)  ==>  unspecific

Stores CHAR in every element of the given STRING and returns an
unspecified value.
s9/help/vectorp000644 001751 001751 00000000142 11203554231 013347 0ustar00nmhnmh000000 000000 R4RS 6.8  (vector? object)  ==>  boolean

Returns #T if OBJECT is a vector, otherwise returns #F.
s9/help/make-vector000644 001751 001751 00000000446 11431711106 014110 0ustar00nmhnmh000000 000000 R4RS 6.8  (make-vector integer)         ==>  vector
          (make-vector integer object)  ==>  vector

Returns a newly allocated vector of INTEGER elements. If a second
argument is given, then each element is initialized to fill.
Otherwise the initial content of each element is unspecified.
s9/help/vector000644 001751 001751 00000000256 11203553064 013200 0ustar00nmhnmh000000 000000 R4RS 6.8  (vector object ...)  ==>  vector

Returns a newly allocated vector whose elements contain the given
arguments. Analogous to LIST.

(vector 'a 'b 'c)  ==>  #(a b c)
s9/help/vector-length000644 001751 001751 00000000132 11203554041 014444 0ustar00nmhnmh000000 000000 R4RS 6.8  (vector-length vector)  ==>  integer

Returns the number of elements in VECTOR.
s9/help/vector-ref000644 001751 001751 00000000337 11431711125 013747 0ustar00nmhnmh000000 000000 R4RS 6.8  (vector-ref vector integer)  ==>  object

INTEGER must be a valid index of VECTOR. VECTOR-REF returns the
contents of the element at the INTEGER'th position of VECTOR.

(vector-ref '#(1 1 2 3 5 8 13 21) 5) ==>  8
s9/help/vector-setb000644 001751 001751 00000000713 11431711127 014130 0ustar00nmhnmh000000 000000 R4RS 6.8  (vector-set! vector integer object)  ==>  unspecific

INTEGER must be a valid index of VECTOR. VECTOR-SET! stores OBJECT
in the element at the INTEGER'th position of VECTOR. The value
returned by VECTOR-SET! is unspecified.

(let ((vec (vector 0 '(2 2 2 2) "Anna")))
  (vector-set! vec 1 '("Sue" "Sue"))
  vec)                                    ==>  #(0 ("Sue" "Sue") "Anna")
(vector-set! '#(0 1 2) 1 "doe")           ==>  error  ; constant vector
s9/help/vector-to-list000644 001751 001751 00000000601 11203547254 014567 0ustar00nmhnmh000000 000000 R4RS 6.8  (vector->list vector)  ==>  list
          (list->vector list)    ==>  vector

VECTOR->LIST returns a newly allocated list of the objects
contained in the elements of VECTOR. LIST->VECTOR returns a
newly created vector initialized to the elements of the list
LIST.

(vector->list '#(dah dah didah))  ==>  (dah dah didah)
(list->vector '(dididit dah))     ==>  #(dididit dah)
s9/help/list-to-vector000755 001751 001751 00000000000 13042075333 017376 2vector-to-listustar00nmhnmh000000 000000 s9/help/vector-fillb000644 001751 001751 00000000226 11203553112 014255 0ustar00nmhnmh000000 000000 R4RS 6.8  (vector-fill! vector object)  ==>  unspecific

Stores OBJECT in every element of VECTOR. The value returned by
VECTOR-FILL! is unspecified.
s9/help/procedurep000644 001751 001751 00000000431 11203551251 014035 0ustar00nmhnmh000000 000000 R4RS 6.9  (procedure? object)  ==>  boolean

Returns #T if OBJECT is a procedure, otherwise returns #F.

(procedure? car)                    ==>  #t
(procedure? 'car)                   ==>  #f
(procedure? (lambda (x) (* x x)))   ==>  #t
(procedure? '(lambda (x) (* x x)))  ==>  #f
s9/help/apply000644 001751 001751 00000000775 11203475033 013030 0ustar00nmhnmh000000 000000 R4RS 6.8  (apply procedure list)             ==>  object
          (apply procedure object ... list)  ==>  object

The first form calls PROCEDURE with the elements of LIST as
the actual arguments. The second form is a generalization of
the first that calls PROCEDURE with the elements of the list
(append (list object ...) LIST) as the actual arguments.

(apply + (list 3 4))                   ==>  7

(define (compose f g)
  (lambda args (f (apply g args)))))
((compose - *) 5 7)                    ==>  -35
s9/help/map000644 001751 001751 00000001410 11203547660 012451 0ustar00nmhnmh000000 000000 R4RS 6.9  (map procedure list1 list2 ...)  ==>  list

The LISTs must be lists, and PROCEDURE must be a procedure taking
as many arguments as there are lists. If more than one list is
given, then they must all be the same length. Map applies PROCEDURE
element-wise to the elements of the lists and returns a list of the
results, in order from left to right. The dynamic order in which
PROCEDURE is applied to the elements of the lists is unspecified.

(map cadr '((a b) (d e) (g h)))             ==>  (b e h)
(map (lambda (n) (expt n n)) '(1 2 3 4 5))  ==>  (1 4 27 256 3125)
(map + '(1 2 3) '(4 5 6))                   ==>  (5 7 9)

(let ((count 0))
  (map (lambda (ignored)
         (set! count (+ count 1))
         count)
       '(a b c)))                 ==>  unspecified
s9/help/for-each000644 001751 001751 00000001056 11203546327 013365 0ustar00nmhnmh000000 000000 R4RS 6.9  (for-each procedure list1 list2 ...)  ==>  unspecific

The arguments to FOR-EACH are like the arguments to MAP, but FOR-EACH
calls PROCEDURE for its side effects rather than for its values.
Unlike MAP, FOR-EACH is guaranteed to call PROCEDURE on the elements
of the lists in order from the first element to the last, and the
value returned by FOR-EACH is unspecified.

(let ((v (make-vector 5)))
  (for-each (lambda (i)
              (vector-set! v i (* i i)))
            '(0 1 2 3 4))
  v)                                      ==>  #(0 1 4 9 16)
s9/help/force000644 001751 001751 00000005757 11203554760 013013 0ustar00nmhnmh000000 000000 R4RS 6.9  (force promise)     ==>  object
          (delay expression)  ==>  promise

FORCE forces the value of PROMISE (see DELAY, section see section
4.2.5 Delayed evaluation). If no value has been computed for the
promise, then a value is computed and returned. The value of the
promise is cached (or "memoized") so that if it is forced a second
time, the previously computed value is returned.

(force (delay (+ 1 2)))        ==>  3
(let ((p (delay (+ 1 2))))
  (list (force p) (force p)))  ==>  (3 3)

(define a-stream
  (letrec ((next (lambda (n)
                   (cons n (delay (next (+ n 1)))))))
    (next 0)))
(define head car)
(define (tail stream) (force (cdr stream)))
(head (tail (tail a-stream)))                ==>  2

FORCE and DELAY are mainly intended for programs written in functional
style. The following examples should not be considered to illustrate
good programming style, but they illustrate the property that only
one value is computed for a promise, no matter how many times it
is forced.

(define count 0)
(define p
  (delay (begin (set! count (+ count 1))
                (if (> count x)
                    count
                    (force p)))))
(define x 5)
p                    ==>  a promise
(force p)            ==>  6
p                    ==>  a promise, still
(begin (set! x 10)
       (force p))    ==>  6

Here is a possible implementation of DELAY and FORCE. Promises are
implemented here as procedures of no arguments, and FORCE simply
calls its argument:

(define force
  (lambda (object)
    (object)))

We define the expression

(delay )

to have the same meaning as the procedure call

(make-promise (lambda () )),

where make-promise is defined as follows:

(define (make-promise proc)
  (let ((result-ready? #f)
        (result #f))
    (lambda ()
      (if result-ready?
          result
          (let ((x (proc)))
            (if result-ready?
                result
                (begin (set! result-ready? #t)
                       (set! result x)
                       result)))))))

Rationale: A promise may refer to its own value, as in the last
example above. Forcing such a promise may cause the promise to be
forced a second time before the value of the first FORCE has been
computed. This complicates the definition of make-promise.

Various extensions to this semantics of DELAY and FORCE are supported
in some implementations:

- Calling FORCE on an object that is not a promise may simply
  return the object.
- It may be the case that there is no means by which a promise
  can be operationally distinguished from its forced value. That
  is, expressions like the following may evaluate to either #T or
  to #F, depending on the implementation:

  (eqv? (delay 1) 1)          ==>  unspecified
  (pair? (delay (cons 1 2)))  ==>  unspecified

- Some implementations may implement "implicit forcing," where
  the value of a promise is forced by primitive procedures like
  cdr and +:

  (+ (delay (* 3 7)) 13)  ==>  34

S9fES does not implement implicit forcing.
s9/help/amb-reset000755 001751 001751 00000000000 13042075333 014226 2ambustar00nmhnmh000000 000000 s9/help/dt000755 001751 001751 00000000000 13042075333 014111 2draw-treeustar00nmhnmh000000 000000 s9/help/delay000755 001751 001751 00000000000 13042075333 014004 2forceustar00nmhnmh000000 000000 s9/help/call-with-input-file000644 001751 001751 00000001644 12537302560 015642 0ustar00nmhnmh000000 000000 R4RS 6.10  (call-with-input-file string procedure^1)   ==>  object
           (call-with-output-file string procedure^1)  ==>  object

PROCEDURE^1 should be a procedure of one argument, and STRING should
be a string naming a file. For CALL-WITH-INPUT-FILE, the file must
already exist; for CALL-WITH-OUTPUT-FILE, the effect is unspecified
if the file already exists. These procedures call PROCEDURE^1 with
one argument: the port obtained by opening the named file for input
or output.  If the file cannot be opened, an error is signalled.
If the procedure returns, then the port is closed automatically and
the value yielded by the procedure is returned. If the procedure
does not return, then the port will not be closed automatically
unless it is possible to prove that the port will never again be
used for a read or write operation.

S9fES silently overwrites the existing file when the file specified
in STRING already exists.
s9/help/call-with-output-file000755 001751 001751 00000000000 13042075333 021705 2call-with-input-fileustar00nmhnmh000000 000000 s9/help/input-portp000644 001751 001751 00000000270 11203546625 014200 0ustar00nmhnmh000000 000000 R4RS 6.10  (input-port? object)   ==>  boolean
           (output-port? object)  ==>  boolean

Returns #T if OBJECT is an input port or output port respectively,
otherwise returns #F.
s9/help/accept-keywords000755 001751 001751 00000000000 13042075333 017512 2keyword-valueustar00nmhnmh000000 000000 s9/help/current-input-port000644 001751 001751 00000000230 11203543450 015465 0ustar00nmhnmh000000 000000 R4RS 6.10  (current-input-port)   ==>  input-port
           (current-output-port)  ==>  output-port

Returns the current default input or output port.
s9/help/with-input-from-file000644 001751 001751 00000001511 12537302702 015661 0ustar00nmhnmh000000 000000 R4RS 6.10  (with-input-from-file string procedure^0)  ==>  object
           (with-output-to-file string procedure^0)   ==>  object

PROCEDURE^0 must be a procedure of no arguments, and STRING must
be a string naming a file. For WITH-INPUT-FROM-FILE, the file must
already exist; for WITH-OUTPUT-TO-FILE, the effect is unspecified
if the file already exists. The file is opened for input or output,
an input or output port connected to it is made the default value
returned by CURRENT-INPUT-PORT or CURRENT-OUTPUT-PORT, and the thunk
is called with no arguments.  When the thunk returns, the port is
closed and the previous default is restored. WITH-INPUT-FROM-FILE
and WITH-OUTPUT-TO-FILE return the value yielded by PROCEDURE^0.

S9fES silently overwrites the existing file when the file specified
with WITH-OUTPUT-TO-FILE already exists.
s9/help/with-output-to-file000755 001751 001751 00000000000 13042075333 021444 2with-input-from-fileustar00nmhnmh000000 000000 s9/help/open-input-file000644 001751 001751 00000000336 12537302613 014713 0ustar00nmhnmh000000 000000 R4RS 6.10  (open-input-file filename)  ==>  input-port

Takes a string naming an existing file and returns an input port
capable of delivering characters from the file. If the file cannot
be opened, an error is signalled.
s9/help/open-output-file000644 001751 001751 00000000637 12537302621 015117 0ustar00nmhnmh000000 000000 R4RS 6.10  (open-output-file filename)  ==>  output-port

Takes a string naming an output file to be created and returns an
output port capable of writing characters to a new file by that
name. If the file cannot be opened, an error is signalled. If a
file with the given name already exists, the effect is unspecified.

S9fES silently overwrites the existing file when the file specified
in STRING already exists.
s9/help/close-input-port000644 001751 001751 00000000554 11203543311 015115 0ustar00nmhnmh000000 000000 R4RS 6.10  (close-input-port input-port)    ==>  unspecific
           (close-output-port output-port)  ==>  unspecific

Closes the file associated with INPUT-PORT or OUTPUT-PORT respectively,
rendering the port incapable of delivering or accepting characters.

These routines have no effect if the file has already been closed.
The value returned is unspecified.
s9/help/close-output-port000755 001751 001751 00000000000 13042075333 020461 2close-input-portustar00nmhnmh000000 000000 s9/help/read000644 001751 001751 00000002062 12033047275 012612 0ustar00nmhnmh000000 000000 R4RS 6.10.2  (read)             ==>  object
             (read input-port)  ==>  object

READ converts external representations of Scheme objects into the
objects themselves. That is, it is a parser for the nonterminal
 (see sections see section 7.1.2 External representations
and see section 6.3 Pairs and lists). READ returns the next object
parsable from the given input port, updating port to point to the
first character past the end of the external representation of the
object.

If an end of file is encountered in the input before any characters
are found that can begin an object, then an end of file object is
returned. The port remains open, and further attempts to read will
also return an end of file object. If an end of file is encountered
after the beginning of an object's external representation, but the
external representation is incomplete and therefore not parsable,
an error is signalled.

The INPUT-PORT argument may be omitted, in which case it defaults
to the value returned by CURRENT-INPUT-PORT. It is an error to read
from a closed port.
s9/help/read-char000644 001751 001751 00000000624 11203551360 013520 0ustar00nmhnmh000000 000000 R4RS 6.10.2  (read-char)             ==>  char | eof-object
             (read-char input-port)  ==>  char | eof-object

Returns the next character available from the input port, updating
the port to point to the following character. If no more characters
are available, an end of file object is returned. INPUT-PORT may
be omitted, in which case it defaults to the value returned by
CURRENT-INPUT-PORT.
s9/help/peek-char000644 001751 001751 00000001514 11203551064 013531 0ustar00nmhnmh000000 000000 R4RS 6.10.2  (peek-char)             ==>  char | eof-object
             (peek-char input-port)  ==>  char | eof-object

Returns the next character available from the input port, without
updating the port to point to the following character. If no more
characters are available, an end of file object is returned.
INPUT-PORT may be omitted, in which case it defaults to the value
returned by CURRENT-INPUT-PORT.

Note: The value returned by a call to PEEK-CHAR is the same as the
value that would have been returned by a call to READ-CHAR with the
same port. The only difference is that the very next call to READ-CHAR
or PEEK-CHAR on that port will return the value returned by the
preceding call to PEEK-CHAR. In particular, a call to PEEK-CHAR on
an interactive port will hang waiting for input whenever a call to
READ-CHAR would have hung.
s9/help/eof-objectp000644 001751 001751 00000000433 11203545017 014067 0ustar00nmhnmh000000 000000 R4RS 6.10.2  (eof-object? object)  ==>  boolean

Returns #T if OBJECT is an end of file object, otherwise returns #F.
The precise set of end of file objects will vary among implementations,
but in any case no end of file object will ever be an object that
can be read in using read.
s9/help/write000644 001751 001751 00000000761 12033047553 013034 0ustar00nmhnmh000000 000000 R4RS 6.10.3  (write object)              ==>  unspecific
             (write object output-port)  ==>  unspecific

Writes a written representation of OBJECT to the given port. Strings
that appear in the written representation are enclosed in double quotes,
and within those strings backslash and double quote characters are
escaped by backslashes. WRITE returns an unspecified value. The
OUTPUT-PORT argument may be omitted, in which case it defaults to
the value returned by CURRENT-OUTPUT-PORT.
s9/help/display000644 001751 001751 00000001470 12033046502 013336 0ustar00nmhnmh000000 000000 R4RS 6.10.3  (display object)              ==>  unspecific
             (display object output-port)  ==>  unspecific

Writes a representation of OBJECT to the given OUTPUT-PORT. Strings
that appear in the written representation are not enclosed in
double quotes, and no characters are escaped within those strings.
Character objects appear in the representation as if written by
write-char instead of by write. DISPLAY returns an unspecified
value. The OUTPUT-PORT argument may be omitted, in which case it
defaults to the value returned by CURRENT-OUTPUT-PORT.

Rationale: WRITE is intended for producing machine-readable output
and DISPLAY is for producing human-readable output. Implementations
that allow "slashification" within symbols will probably want WRITE
but not DISPLAY to slashify funny characters in symbols.
s9/help/newline000644 001751 001751 00000000545 11203550401 013330 0ustar00nmhnmh000000 000000 R4RS 6.10.3  (newline)              ==>  unspecific
             (newline output-port)  ==>  unspecific

Writes an end of line to OUTPUT-PORT. Exactly how this is done
differs from one operating system to another. Returns an unspecified
value. The OUTPUT-PORT argument may be omitted, in which case it
defaults to the value returned by CURRENT-OUTPUT-PORT.
s9/help/write-char000644 001751 001751 00000000552 11203554451 013743 0ustar00nmhnmh000000 000000 R4RS 6.10.3  (write-char char)              ==>  unspecific
             (write-char char output-port)  ==>  unspecific

Writes the character CHAR (not an external representation of the
character) to the given port and returns an unspecified value. The
OUTPUT-PORT argument may be omitted, in which case it defaults to
the value returned by CURRENT-OUTPUT-PORT.
s9/help/load000644 001751 001751 00000001104 11203547355 012614 0ustar00nmhnmh000000 000000 R4RS 6.10.4  (load string)  ==>  unspecific

STRING should be a file name naming an existing file containing
Scheme source code. The LOAD procedure reads expressions and
definitions from the file and evaluates them sequentially. It is
unspecified whether the results of the expressions are printed.
The LOAD procedure does not affect the values returned by
CURRENT-INPUT-PORT and CURRENT-OUTPUT-PORT. LOAD returns an
unspecified value.

Rationale: For portability, LOAD must operate on source files. Its
operation on other kinds of files necessarily varies among
implementations.
s9/help/assoc000755 001751 001751 00000000000 13042075333 013667 2assqustar00nmhnmh000000 000000 s9/help/bitstar000755 001751 001751 00000000000 13042075333 014116 2bit0ustar00nmhnmh000000 000000 s9/help/macro-expand-1000755 001751 001751 00000000000 13042075333 016702 2macro-expandustar00nmhnmh000000 000000 s9/help/file-existsp000644 001751 001751 00000000202 11203545774 014312 0ustar00nmhnmh000000 000000 S9fES  (file-exists? string)  ==>  boolean

Return #T if the file specifed in the STRING argument exists and
otherwise return #F.
s9/help/fold-left000644 001751 001751 00000001632 11203546157 013556 0ustar00nmhnmh000000 000000 S9fES  (fold-left procedure object list ...)  ==>  object

Fold a series of lists by combining the result so far with adjacent
members of the given LISTs by PROCEDURE. PROCEDURE must by a K-ary
procedure where K is the number of lists passed to FOLD-LEFT plus
one. OBJECT is the base element that is used in the place of the
intermediate result in the first application of PROCEDURE. FOLD-LEFT
folds lists by grouping applications of PROCEDURE to the left.

Applications of FOLD-LEFT can be rewritten as follows:

(fold-left p2 0 (a b))              ==  (p2 (p2 0 a) b)
(fold-left p3 0 (a b) (c d))        ==  (p3 (p3 0 a c) b d)
(fold-left p4 0 (a b) (c d) (e f))  ==  (p4 (p4 0 a c e) b d f)

(fold-left cons 0 '(1 2 3))              ==>  (((0 . 1) . 2) . 3)
(fold-left list 0 '(1 2) '(3 4) '(5 6))  ==>  ((0 1 3 5) 2 4 6)
(fold-left + 0 '(1 2 3))                 ==>  6
(fold-left - 0 '(1 2 3))                 ==>  -6
s9/help/fold-right000644 001751 001751 00000001650 11203546262 013736 0ustar00nmhnmh000000 000000 S9fES  (fold-right procedure object list ...)  ==>  object

Fold a set of lists by combining the result so far with adjacent
members of the given LISTs by PROCEDURE. PROCEDURE must by a K-ary
procedure where K is the number of lists passed to FOLD-RIGHT plus
one. OBJECT is the base element that is combined with the intermediate
result in the last application of PROCEDURE. FOLD-RIGHT folds lists
by grouping applications of PROCEDURE to the right.

Applications of FOLD-RIGHT can be rewritten as follows:

(fold-right p2 0 (a b))              ==  (p2 a (p2 b 0))
(fold-right p3 0 (a b) (c d))        ==  (p3 a c (p3 b d 0))
(fold-right p4 0 (a b) (c d) (e f))  ==  (p4 a c e (p4 b d f 0))

(fold-right cons 0 '(1 2 3))              ==>  (1 2 3 . 0)
(fold-right list 0 '(1 2) '(3 4) '(5 6))  ==>  (1 3 5 (2 4 6 0))
(fold-right + 0 '(1 2 3))                 ==>  6
(fold-right - 0 '(1 2 3))                 ==>  2 ; (- 1 (- 2 (- 3 0)))
s9/help/gensym000644 001751 001751 00000000674 12046421105 013200 0ustar00nmhnmh000000 000000 S9fES  (gensym symbol)  ==>  symbol
       (gensym string)  ==>  symbol
       (gensym)         ==>  symbol

Return a fresh symbol that is guaranteed to be unique. When SYMBOL
or STRING is passed to GENSYM, the returned symbol will have its
characters as a prefix.

(gensym)        ==>  g56
(gensym "foo")  ==>  foo57
(gensym 'bar)   ==>  bar58

(let ((a (gensym))
      (b (gensym))
      (c (gensym)))
  (list a b c))      ==>  (g63 g62 g61)
s9/help/load-from-library000644 001751 001751 00000000557 11203547402 015223 0ustar00nmhnmh000000 000000 S9fES  (load-from-library string)  ==>  unspecific

Locate the Scheme source file whose name is specified in STRING and
load it. It is an error to specify a file that cannot be located.
LOAD-FROM-LIBRARY uses LOCATE-FILE to locate a file and LOAD to
load it. It is intended to load files from extension libraries that
may be stored in a set of pre-defined locations.
s9/help/locate-file000644 001751 001751 00000001771 11203547513 014067 0ustar00nmhnmh000000 000000 S9fES  (locate-file string)  ==>  string | #f

Attempt to locate the file specified in STRING in a pre-defined set
of directories. The directories to search are stored in the
*LIBRARY-PATH* variable as a colon-separated list of paths. LOCATE-FILE
appends a slash (/) and the given file name to each path of
*LIBRARY-PATH* and then checks the existence of the resulting fully
qualified file name by using FILE-EXISTS?. It returns the first
fully qualified file name that exists or #F in case the file could
not be located.

; Given *LIBRARY-PATH* == .:/u/s9fes
; and hello.scm in /u/s9fes/examples

(locate-file "examples/hello.scm")  ==>  "/u/s9fes/examples/hello.scm"
(locate-file "non-existent")        ==>  #f

Rationale: LOCATE-FILE is intended to locate files that belong to
the S9fES system, like extension library files, user library files,
and help files. The value of *LIBRARY-PATH* is initialized when
the Scheme system starts up, for example by copying it from the
S9FES_LIBRARY_PATH environment variable.
s9/help/print000644 001751 001751 00000000530 11203551233 013021 0ustar00nmhnmh000000 000000 S9fES  (print object ...)  ==>  unspecific

Write the external representation of each given OBJECT to the port
returned by CURRENT-OUTPUT-PORT. Use WRITE to write each external
representation. Display one space character between adjacent objects.
Display a newline sequence after the last object. PRINT with no
arguments is equal to (NEWLINE).
s9/help/set-input-portb000644 001751 001751 00000000365 11203551452 014752 0ustar00nmhnmh000000 000000 S9fES  (set-input-port! input-port)    ==>  unspecific
       (set-output-port! output-port)  ==>  unspecific

Change the default input and output ports by mutating the values
returned by CURRENT-INPUT-PORT and CURRENT-OUTPUT-PORT respectively.
s9/help/symbols000644 001751 001751 00000000117 11203553025 013357 0ustar00nmhnmh000000 000000 S9fES  (symbols)  ==>  list

Return a list of all symbols known to the system.
s9/help/begin000644 001751 001751 00000001045 11203542541 012755 0ustar00nmhnmh000000 000000 R4RS 4.2.3  (begin   ...)  ==>  object

The s are evaluated sequentially from left to right,
and the value of the last expression is returned. This expression
type is used to sequence side effects such as input and output.

(define x 0)

(begin (set! x 5)
       (+ x 1))                      ==>  6

(begin (display "4 plus 1 equals ")
       (display (+ 4 1)))            ==>  unspecific
       ; side effect: print 4 plus 1 equals 5

S9fES allows BEGIN to take zero arguments, returning an unspecific
value.
s9/help/case000644 001751 001751 00000002514 11203542560 012607 0ustar00nmhnmh000000 000000 R4RS 4.2.1  (case    ...)  ==>  object

Syntax:  may be any expression. Each  should have the
form

(( ...)   ...),

where each  is an external representation of some object.
All the s must be distinct. The last  may be an "else
clause," which has the form

(else   ...).

Semantics: A CASE expression is evaluated as follows.  is
evaluated and its result is compared against each . If the
result of evaluating  is equivalent (in the sense of EQV?; see
section see section 6.2 Equivalence predicates) to a , then
the expressions in the corresponding  are evaluated from
left to right and the result of the last expression in the 
is returned as the result of the CASE expression. If the result of
evaluating  is different from every , then if there is
an ELSE clause its expressions are evaluated and the result of the
last is the result of the case expression; otherwise the result of
the CASE expression is unspecified.

(case (* 2 3)
  ((2 3 5 7) 'prime)
  ((1 4 6 8 9) 'composite))  ==>  composite

(case (car '(c d))
  ((a) 'a)
  ((b) 'b))                  ==>  unspecific

(case (car '(c d))
  ((a e i o u) 'vowel)
  ((w y) 'semivowel)
  (else 'consonant))         ==>  consonant
s9/help/cond000644 001751 001751 00000003160 11203543404 012613 0ustar00nmhnmh000000 000000 R4RS 4.2.1  (cond   ...)  ==>  object

Syntax: Each  should be of the form

(  ...)

where  is any expression. The last  may be an "else
clause," which has the form

(else   ...).

Semantics: A COND expression is evaluated by evaluating the 
expressions of successive s in order until one of them
evaluates to a true value (see section see section 6.1 Booleans).
When a  evaluates to a true value, then the remaining
s in its  are evaluated in order, and the result
of the last  in the  is returned as the result
of the entire COND expression. If the selected  contains
only the  and no s, then the value of the 
is returned as the result. If all s evaluate to false values,
and there is no ELSE clause, then the result of the conditional
expression is unspecified; if there is an ELSE clause, then its
s are evaluated, and the value of the last one is
returned.

(cond ((> 3 2) 'greater)
      ((< 3 2) 'less))    ==>  greater

(cond ((> 3 3) 'greater)
      ((< 3 3) 'less)
      (else 'equal))      ==>  equal

Some implementations support an alternative  syntax,

( => ),

where  is an expression. If  evaluates to a true
value, then  is evaluated. Its value must be a procedure
of one argument; this procedure is then invoked on the value of the
.

(cond ((assv 'b '((a 1) (b 2))) => cadr)
      (else #f))                          ==>  2

S9fES does support the alternative clause syntax.
s9/help/define000644 001751 001751 00000005422 11414544261 013133 0ustar00nmhnmh000000 000000 R4RS 5.2  (define  )         ==>  unspecific
          (define ( ) )   ==>  unspecific
          (define ( . ) )  ==>  unspecific

Definitions are valid in some, but not all, contexts where expressions
are allowed. They are valid only at the top level of a 
and, in some implementations, at the beginning of a .

A definition should have one of the following forms:

- (define  )

- (define ( ) )
   should be either a sequence of zero or more variables,
  or a sequence of one or more variables followed by a space-delimited
  period and another variable (as in a lambda expression). This form
  is equivalent to

  (define 
    (lambda () )).

- (define ( . ) )
   should be a single variable. This form is equivalent to

  (define 
    (lambda  )).

- (begin  ...)
  This form is equivalent to the set of definitions that form the
  body of the begin.

5.2.1 Top level definitions

At the top level of a program, a definition

(define  )

has essentially the same effect as the assignment expression

(set!  )

if  is bound. If  is not bound, however, then
the definition will bind  to a new location before
performing the assignment, whereas it would be an error to perform
a set! on an unbound variable.

(define add3
  (lambda (x) (+ x 3)))
(add3 3)                 ==>  6
(define first car)
(first '(1 2))           ==>  1

5.2.2 Internal definitions

Some implementations of Scheme permit definitions to occur at the
beginning of a  (that is, the body of a LAMBDA, LET, LET*,
LETREC, or DEFINE expression). Such definitions are known as internal
definitions as opposed to the top level definitions described above.
The variable defined by an internal definition is local to the
. That is,  is bound rather than assigned, and the
region of the binding is the entire . For example,

(let ((x 5))
  (define foo (lambda (y) (bar x y)))
  (define bar (lambda (a b) (+ (* a b) a)))
  (foo (+ x 3)))                             ==>  45

A  containing internal definitions can always be converted
into a completely equivalent LETREC expression. For example, the
let expression in the above example is equivalent to

(let ((x 5))
  (letrec ((foo (lambda (y) (bar x y)))
           (bar (lambda (a b) (+ (* a b) a))))
    (foo (+ x 3))))

Just as for the equivalent LETREC expression, it must be possible
to evaluate each  of every internal definition in a
 without assigning or referring to the value of any 
being defined.

S9fES does support local definitions.
s9/help/do000644 001751 001751 00000003626 11775332625 012320 0ustar00nmhnmh000000 000000 R4RS 4.2.4  (do   )  ==>  object

More specifically, the DO syntax is:

(do ((  )
     ...)
    (  ...)
   ...)

DO is an iteration construct. It specifies a set of variables to
be bound, how they are to be initialized at the start, and how they
are to be updated on each iteration. When a termination condition
is met, the loop exits with a specified result value.

DO expressions are evaluated as follows: The  expressions are
evaluated (in some unspecified order), the s are bound
to fresh locations, the results of the  expressions are stored
in the bindings of the s, and then the iteration phase
begins.

Each iteration begins by evaluating ; if the result is false
(see section see section 6.1 Booleans), then the  expressions
are evaluated in order for effect, the  expressions are
evaluated in some unspecified order, the s are bound to
fresh locations, the results of the s are stored in the
bindings of the s, and the next iteration begins.

If  evaluates to a true value, then the s are
evaluated from left to right and the value of the last 
is returned as the value of the DO expression. If no s
are present, then the value of the DO expression is unspecified.

The region of the binding of a  consists of the entire
DO expression except for the s. It is an error for a 
to appear more than once in the list of DO variables.

A  may be omitted, in which case the effect is the same as
if `(  )' had been written instead of
`( )'.

(do ((vec (make-vector 5))
     (i 0 (+ i 1)))
    ((= i 5) vec)
  (vector-set! vec i i))         ==>  #(0 1 2 3 4)

(let ((x '(1 3 5 7 9)))
  (do ((x x (cdr x))
       (sum 0 (+ sum (car x))))
      ((null? x) sum)))          ==>  25
s9/help/if000644 001751 001751 00000001275 11203546604 012300 0ustar00nmhnmh000000 000000 R4RS 4.1.5  (if   )  ==>  object
            (if  )              ==>  object

Syntax: , , and  may be arbitrary
expressions.

Semantics: An IF expression is evaluated as follows: first, 
is evaluated. If it yields a true value (see section see section
6.1 Booleans), then  is evaluated and its value is
returned. Otherwise  is evaluated and its value is
returned. If  yields a false value and no  is
specified, then the result of the expression is unspecified.

(if (> 3 2) 'yes 'no)  ==>  yes
(if (> 2 3) 'yes 'no)  ==>  no
(if (> 3 2)
    (- 3 2)
    (+ 3 2))           ==>  1
s9/help/lambda000644 001751 001751 00000004352 11775333146 013132 0ustar00nmhnmh000000 000000 R4RS 4.1.4  (lambda  )  ==>  procedure

Syntax:  should be a formal arguments list as described
below, and  should be a sequence of one or more expressions.

Semantics: A LAMBDA expression evaluates to a procedure. The
environment in effect when the LAMBDA expression was evaluated is
remembered as part of the procedure. When the procedure is later
called with some actual arguments, the environment in which the
LAMBDA expression was evaluated will be extended by binding the
variables in the formal argument list to fresh locations, the
corresponding actual argument values will be stored in those
locations, and the expressions in the body of the LAMBDA expression
will be evaluated sequentially in the extended environment. The
result of the last expression in the body will be returned as the
result of the procedure call.

(lambda (x) (+ x x))      ==>  a procedure
((lambda (x) (+ x x)) 4)  ==>  8

(define reverse-subtract
  (lambda (x y) (- y x)))
(reverse-subtract 7 10)     ==>  3

(define add4
  (let ((x 4))
    (lambda (y) (+ x y))))
(add4 6)                    ==>  10

 should have one of the following forms:

- ( ...): The procedure takes a fixed number of arguments;
  when the procedure is called, the arguments will be stored in the
  bindings of the corresponding variables.

- : The procedure takes any number of arguments; when the
  procedure is called, the sequence of actual arguments is converted
  into a newly allocated list, and the list is stored in the binding
  of the .

- ( ...  . ): If a space-delimited
  period precedes the last variable, then the value stored in the
  binding of the last variable will be a newly allocated list of
  the actual arguments left over after all the other actual arguments
  have been matched up against the other formal arguments.

It is an error for a  to appear more than once in .

((lambda x x) 3 4 5 6)          ==>  (3 4 5 6)
((lambda (x y . z) z) 3 4 5 6)  ==>  (5 6)

Each procedure created as the result of evaluating a LAMBDA expression
is tagged with a storage location, in order to make EQV? and EQ?
work on procedures (see section see section 6.2 Equivalence
predicates).
s9/help/let000644 001751 001751 00000003322 11775333304 012466 0ustar00nmhnmh000000 000000 R4RS 4.2.2  (let  )  ==>  object

Syntax:  should have the form

(( ) ...),

where each  is an expression, and  should be a sequence
of one or more expressions. It is an error for a  to
appear more than once in the list of variables being bound.

Semantics: The s are evaluated in the current environment (in
some unspecified order), the s are bound to fresh locations
holding the results, the  is evaluated in the extended
environment, and the value of the last expression of  is
returned. Each binding of a  has  as its region.

(let ((x 2) (y 3))
  (* x y))            ==>  6

(let ((x 2) (y 3))
  (let ((x 7)
        (z (+ x y)))
    (* z x)))         ==>  35

4.2.4 (let   ) ==> object

Some implementations of Scheme permit a variant on the syntax of
LET called "named let" which provides a more general looping construct
than DO, and may also be used to express recursions.

Named LET has the same syntax and semantics as ordinary LET except
that  is bound within  to a procedure whose formal
arguments are the bound variables and whose body is . Thus
the execution of  may be repeated by invoking the procedure
named by .

(let loop ((numbers '(3 -2 1 6 -5))
           (nonneg '())
           (neg '()))
  (cond ((null? numbers) (list nonneg neg))
        ((>= (car numbers) 0)
          (loop (cdr numbers)
                (cons (car numbers) nonneg)
                neg))
        ((< (car numbers) 0)
          (loop (cdr numbers)
                nonneg
                (cons (car numbers) neg)))))
          ==>  ((6 1 3) (-5 -2))

S9fES does support named LET.
s9/help/quasiquote000644 001751 001751 00000004620 11440124402 014066 0ustar00nmhnmh000000 000000 R4RS 4.2.6  (quasiquote