diff --git a/Makefile b/Makefile index deb8c99..d671b23 100644 --- a/Makefile +++ b/Makefile @@ -158,7 +158,7 @@ enough: $(VM) $(IMAGE) go $(LIBCIG) scsh $(LIBSCSH) # External code to include in the VM # After changing any of these you should delete `scheme48vm' and remake it. -CIGGED = flock network select syscalls tty time sighandlers +CIGGED = flock network select syscalls tty time sighandlers re_low #re rdelim CIGGEDOBJ = $(patsubst %,scsh/%.o, $(CIGGED)) CIGGEDINIT = $(patsubst %,s48_init_%, $(CIGGED)) @@ -292,10 +292,10 @@ c/fake/strerror.o: c/fake/strerror.h $(IMAGE): $(VM) scheme/env/init-defpackage.scm scheme/more-interfaces.scm \ scheme/link-packages.scm scheme/more-packages.scm \ $(usual-files) build/initial.debug build/build-usual-image - sh $(srcdir)/build/build-usual-image "$(srcdir)" "$(LIB)" "$(IMAGE)" \ - "$(VM)" "$(INITIAL)" -# build/build-usual-image . "`pwd`/scheme" '$(IMAGE)' './$(VM)' \ -# '$(INITIAL)' +# sh $(srcdir)/build/build-usual-image "$(srcdir)" "$(LIB)" "$(IMAGE)" \ +# "$(VM)" "$(INITIAL)" + build/build-usual-image . "`pwd`/scheme" '$(IMAGE)' './$(VM)' \ + '$(INITIAL)' ### Fake targets: all clean install man dist @@ -540,7 +540,7 @@ link/linker-in-lucid: build/lucid-script.lisp $(linker-files) \ # no debugging environment to speak of. $(INITIAL): $(LINKER_IMAGE) $(CONFIG_FILES) build/initial.scm $(initial-files) \ - scsh/scsh-read.scm scsh/here.scm # gross and Olin hates it -bri + scsh/here.scm # gross and Olin hates it -bri ($(START_LINKER); \ echo '(load-configuration "scheme/interfaces.scm")'; \ echo '(load-configuration "scheme/packages.scm")'; \ @@ -654,7 +654,7 @@ i-know-what-i-am-doing: echo ',exec ,load compile-vm-no-gc.scm'; \ echo ',exec ,load compile-gc.scm'; \ echo ',exit' \ - ) | $(RUNNABLE) -h 5000000 && \ + ) | $(RUNNABLE) -h 8000000 && \ mv ../scheme/vm/scheme48vm.c ../scheme/vm/scheme48heap.c ../c cig: $(CIG) $(CIG).image $(LIBCIG) @@ -671,7 +671,7 @@ $(CIG): $(VM) $(IMAGE) $(srcdir)/cig/cig.scm $(srcdir)/cig/libcig.scm | ./$(VM) -i ./$(IMAGE) $(srcdir)/cig/image2script $(LIB)/$(VM) $(CIG) -chmod +x $(CIG) -# mv /tmp/cig $(srcdir)/cig/standalone.image + mv /tmp/cig $(srcdir)/cig/standalone.image $(RM) /tmp/cig $(CIG)2: diff --git a/Makefile.in b/Makefile.in index 0668425..50ccf56 100644 --- a/Makefile.in +++ b/Makefile.in @@ -158,7 +158,7 @@ enough: $(VM) $(IMAGE) go $(LIBCIG) scsh $(LIBSCSH) # External code to include in the VM # After changing any of these you should delete `scheme48vm' and remake it. -CIGGED = flock network select syscalls tty time sighandlers +CIGGED = flock network select syscalls tty time sighandlers re_low #re rdelim CIGGEDOBJ = $(patsubst %,scsh/%.o, $(CIGGED)) CIGGEDINIT = $(patsubst %,s48_init_%, $(CIGGED)) @@ -292,10 +292,10 @@ c/fake/strerror.o: c/fake/strerror.h $(IMAGE): $(VM) scheme/env/init-defpackage.scm scheme/more-interfaces.scm \ scheme/link-packages.scm scheme/more-packages.scm \ $(usual-files) build/initial.debug build/build-usual-image - sh $(srcdir)/build/build-usual-image "$(srcdir)" "$(LIB)" "$(IMAGE)" \ - "$(VM)" "$(INITIAL)" -# build/build-usual-image . "`pwd`/scheme" '$(IMAGE)' './$(VM)' \ -# '$(INITIAL)' +# sh $(srcdir)/build/build-usual-image "$(srcdir)" "$(LIB)" "$(IMAGE)" \ +# "$(VM)" "$(INITIAL)" + build/build-usual-image . "`pwd`/scheme" '$(IMAGE)' './$(VM)' \ + '$(INITIAL)' ### Fake targets: all clean install man dist @@ -540,7 +540,7 @@ link/linker-in-lucid: build/lucid-script.lisp $(linker-files) \ # no debugging environment to speak of. $(INITIAL): $(LINKER_IMAGE) $(CONFIG_FILES) build/initial.scm $(initial-files) \ - scsh/scsh-read.scm scsh/here.scm # gross and Olin hates it -bri + scsh/here.scm # gross and Olin hates it -bri ($(START_LINKER); \ echo '(load-configuration "scheme/interfaces.scm")'; \ echo '(load-configuration "scheme/packages.scm")'; \ @@ -654,7 +654,7 @@ i-know-what-i-am-doing: echo ',exec ,load compile-vm-no-gc.scm'; \ echo ',exec ,load compile-gc.scm'; \ echo ',exit' \ - ) | $(RUNNABLE) -h 5000000 && \ + ) | $(RUNNABLE) -h 8000000 && \ mv ../scheme/vm/scheme48vm.c ../scheme/vm/scheme48heap.c ../c cig: $(CIG) $(CIG).image $(LIBCIG) @@ -671,7 +671,7 @@ $(CIG): $(VM) $(IMAGE) $(srcdir)/cig/cig.scm $(srcdir)/cig/libcig.scm | ./$(VM) -i ./$(IMAGE) $(srcdir)/cig/image2script $(LIB)/$(VM) $(CIG) -chmod +x $(CIG) -# mv /tmp/cig $(srcdir)/cig/standalone.image + mv /tmp/cig $(srcdir)/cig/standalone.image $(RM) /tmp/cig $(CIG)2: diff --git a/build/initial.debug b/build/initial.debug index 489ec8b..42a175e 100644 --- a/build/initial.debug +++ b/build/initial.debug @@ -6364,39 +6364,39 @@ (4339 loop 4338 95 ()) (4340 #f 4296 24099 ()) (4341 loop 4340 95 ()) -(4342 #f 4296 26314 ()) -(4343 #f 4296 26477 ()) -(4344 #f 4296 26526 ()) -(4345 #f 4296 26575 ()) -(4346 #f 4296 26720 ()) -(4347 #f 4296 26938 ()) -(4348 #f 4296 29861 ()) -(4349 #f 4296 30061 ()) -(4350 #f 4296 30110 ()) -(4351 #f 4296 30159 ()) +(4342 #f 4296 26227 ()) +(4343 #f 4296 26390 ()) +(4344 #f 4296 26439 ()) +(4345 #f 4296 26488 ()) +(4346 #f 4296 26633 ()) +(4347 #f 4296 26851 ()) +(4348 #f 4296 29774 ()) +(4349 #f 4296 29974 ()) +(4350 #f 4296 30023 ()) +(4351 #f 4296 30072 ()) (4352 #f 4351 146 ()) -(4353 #f 4296 30208 ()) +(4353 #f 4296 30121 ()) (4354 #f 4353 329 ()) (4355 #f 4353 403 ()) -(4356 #f 4296 30587 ()) -(4357 #f 4296 30636 ()) +(4356 #f 4296 30500 ()) +(4357 #f 4296 30549 ()) (4358 #f 4357 176 ()) -(4359 parse-package-clauses 4296 30694 ()) +(4359 parse-package-clauses 4296 30607 ()) (4360 loop 4359 76 ()) -(4361 #f 4296 30703 ()) +(4361 #f 4296 30616 ()) (4362 #f 4361 35 ()) (4363 #f 4362 146 ()) -(4364 #f 4296 30959 ()) -(4365 #f 4296 31008 ()) +(4364 #f 4296 30872 ()) +(4365 #f 4296 30921 ()) (4366 loop 4365 35 ()) -(4367 #f 4296 31121 ()) -(4368 #f 4296 31202 ()) -(4369 #f 4296 31283 ()) +(4367 #f 4296 31034 ()) +(4368 #f 4296 31115 ()) +(4369 #f 4296 31196 ()) (4370 loop 4369 51 ()) (4371 #f 4369 90 ()) (4372 #f 4369 114 ()) -(4373 #f 4296 31364 ()) -(4374 #f 4296 32621 ()) -(4375 #f 4296 32757 ()) +(4373 #f 4296 31277 ()) +(4374 #f 4296 32534 ()) +(4375 #f 4296 32670 ()) (4376 #f #f #f ()) - diff --git a/build/initial.image b/build/initial.image index d4eb8d0..8dd6d29 100644 Binary files a/build/initial.image and b/build/initial.image differ diff --git a/scheme/interfaces.scm b/scheme/interfaces.scm index c1bfd15..25fa078 100644 --- a/scheme/interfaces.scm +++ b/scheme/interfaces.scm @@ -757,6 +757,7 @@ procedure-type-arity any-procedure-type (proc :syntax) + (some-values :syntax) boolean-type char-type @@ -1112,6 +1113,7 @@ (export ((:syntax :values :arguments :value) :type) (procedure (proc (:type :type) :type)) ; (procedure T1 T2) (proc :syntax) ; (proc (T1 ... Tn) T) + (some-values :syntax) ; (some-values T1 ... Tn) ;JMG added it again ((:boolean :char :number diff --git a/scsh/dbm.c b/scsh/dbm.c index 7fb0386..5906c2d 100644 --- a/scsh/dbm.c +++ b/scsh/dbm.c @@ -49,7 +49,7 @@ s48_value df_db_open_btree(long nargs, s48_value *args) DB** r2; cig_check_nargs(11, nargs, "db_open_btree"); - r1 = db_open_btree(cig_string_body(args[10]), s48_extract_fixnum(args[9]), s48_extract_fixnum(args[8]), s48_extract_fixnum(args[7]), s48_extract_fixnum(args[6]), EXTRACT_FIXNUM(args[5]), EXTRACT_FIXNUM(args[4]), EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), &r2); + r1 = db_open_btree(cig_string_body(args[10]), s48_extract_fixnum(args[9]), s48_extract_fixnum(args[8]), s48_extract_fixnum(args[7]), s48_extract_fixnum(args[6]), s48_extract_fixnum(args[5]), EXTRACT_FIXNUM(args[4]), EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), &r2); ret1 = errno_or_false(r1); AlienVal(VECTOR_REF(*args,0)) = (long) r2; return ret1; @@ -63,7 +63,7 @@ s48_value df_db_open_hash(long nargs, s48_value *args) DB** r2; cig_check_nargs(10, nargs, "db_open_hash"); - r1 = db_open_hash(cig_string_body(args[9]), s48_extract_fixnum(args[8]), s48_extract_fixnum(args[7]), s48_extract_fixnum(args[6]), s48_extract_fixnum(args[5]), EXTRACT_FIXNUM(args[4]), EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), &r2); + r1 = db_open_hash(cig_string_body(args[9]), s48_extract_fixnum(args[8]), s48_extract_fixnum(args[7]), s48_extract_fixnum(args[6]), s48_extract_fixnum(args[5]), s48_extract_fixnum(args[4]), EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), &r2); ret1 = errno_or_false(r1); AlienVal(VECTOR_REF(*args,0)) = (long) r2; return ret1; @@ -77,7 +77,7 @@ s48_value df_db_open_recno(long nargs, s48_value *args) DB** r2; cig_check_nargs(12, nargs, "db_open_recno"); - r1 = db_open_recno(cig_string_body(args[11]), s48_extract_fixnum(args[10]), s48_extract_fixnum(args[9]), s48_extract_fixnum(args[8]), s48_extract_fixnum(args[7]), EXTRACT_FIXNUM(args[6]), EXTRACT_FIXNUM(args[5]), EXTRACT_FIXNUM(args[4]), EXTRACT_FIXNUM(args[3]), s48_extract_char(args[2]), cig_string_body(args[1]), &r2); + r1 = db_open_recno(cig_string_body(args[11]), s48_extract_fixnum(args[10]), s48_extract_fixnum(args[9]), s48_extract_fixnum(args[8]), s48_extract_fixnum(args[7]), s48_extract_fixnum(args[6]), EXTRACT_FIXNUM(args[5]), EXTRACT_FIXNUM(args[4]), EXTRACT_FIXNUM(args[3]), s48_extract_char(args[2]), cig_string_body(args[1]), &r2); ret1 = errno_or_false(r1); AlienVal(VECTOR_REF(*args,0)) = (long) r2; return ret1; diff --git a/scsh/flock.c b/scsh/flock.c index 3c921a1..2d2b078 100644 --- a/scsh/flock.c +++ b/scsh/flock.c @@ -1,6 +1,6 @@ /* This is an Scheme48/C interface file, ** automatically generated by a hacked version of cig 3.0. -step 3 +step 4 */ #include diff --git a/scsh/flock.scm b/scsh/flock.scm index 5a4eb63..fce6bc0 100644 --- a/scsh/flock.scm +++ b/scsh/flock.scm @@ -8,6 +8,9 @@ ;;; C syscall interface ;;;;;;;;;;;;;;;;;;;;;;; +(foreign-init-name "flock") + + (foreign-source "#include " "#include " diff --git a/scsh/network.c b/scsh/network.c index 5f04645..d79fee5 100644 --- a/scsh/network.c +++ b/scsh/network.c @@ -1,6 +1,6 @@ /* This is an Scheme48/C interface file, ** automatically generated by a hacked version of cig 3.0. -step 3 +step 4 */ #include @@ -58,7 +58,7 @@ s48_value df_scheme_connect(s48_value g1, s48_value g2, s48_value g3) s48_value df_listen(s48_value g1, s48_value g2) { - extern int listen(int , int ); + s48_value ret1; int r1; diff --git a/scsh/network.scm b/scsh/network.scm index 1452eb0..29e7aa3 100644 --- a/scsh/network.scm +++ b/scsh/network.scm @@ -4,6 +4,8 @@ ;;; Scheme48 implementation. +(foreign-init-name "network") + (foreign-source "#include " "#include " diff --git a/scsh/regexp/regcomp.o b/scsh/regexp/regcomp.o index be7b76c..92b00c5 100644 Binary files a/scsh/regexp/regcomp.o and b/scsh/regexp/regcomp.o differ diff --git a/scsh/regexp/regexec.o b/scsh/regexp/regexec.o index d9d2a02..267f74b 100644 Binary files a/scsh/regexp/regexec.o and b/scsh/regexp/regexec.o differ diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index e3465f8..45b69cb 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -159,7 +159,7 @@ records extended-ports partial-s48-ports -; ports + ports build bigbit bitwise @@ -396,12 +396,12 @@ interrupts) (files event)) -(define-structure test-package (export test-proc) - (open scsh-regexp-package scheme) - (begin (define (test-proc p) - (regexp-substitute p - (string-match "(foo)(.*)(bar)" "Hello foo Olin bar quux") - 'post 3 1 2 'pre)))) +;(define-structure test-package (export test-proc) +; (open scsh-regexp-package scheme) +; (begin (define (test-proc p) +; (regexp-substitute p +; (string-match "(foo)(.*)(bar)" "Hello foo Olin bar quux") +; 'post 3 1 2 'pre)))) (define-structure scsh-threads diff --git a/scsh/select.c b/scsh/select.c index 39fddd2..4b52698 100644 --- a/scsh/select.c +++ b/scsh/select.c @@ -1,6 +1,6 @@ /* This is an Scheme48/C interface file, ** automatically generated by a hacked version of cig 3.0. -step 3 +step 4 */ #include diff --git a/scsh/select.scm b/scsh/select.scm index 4439947..ee53fb6 100644 --- a/scsh/select.scm +++ b/scsh/select.scm @@ -1,6 +1,9 @@ ;;; select(2) syscall for scsh. -*- Scheme -*- ;;; Copyright (c) 1995 by Olin Shivers. +(foreign-init-name "select") + + (foreign-source "/* Make sure foreign-function stubs interface to the C funs correctly: */" "#include \"select1.h\"" diff --git a/scsh/sighandlers.c b/scsh/sighandlers.c index 7dad99c..48279e4 100644 --- a/scsh/sighandlers.c +++ b/scsh/sighandlers.c @@ -1,6 +1,6 @@ /* This is an Scheme48/C interface file, ** automatically generated by a hacked version of cig 3.0. -step 3 +step 4 */ #include diff --git a/scsh/startup.scm b/scsh/startup.scm index c4f505b..540c10d 100644 --- a/scsh/startup.scm +++ b/scsh/startup.scm @@ -8,7 +8,7 @@ (define (make-scsh-starter) (let ((context (user-context))) (lambda (args) - (display "off we go") + (display "off we go" (current-error-port)) (display context) (parse-switches-and-execute args context)))) diff --git a/scsh/syscalls.c b/scsh/syscalls.c index bf7990b..93e954a 100644 --- a/scsh/syscalls.c +++ b/scsh/syscalls.c @@ -1,6 +1,6 @@ /* This is an Scheme48/C interface file, ** automatically generated by a hacked version of cig 3.0. -step 3 +step 4 */ #include diff --git a/scsh/time.c b/scsh/time.c index 4f0231c..ab930cf 100644 --- a/scsh/time.c +++ b/scsh/time.c @@ -1,6 +1,6 @@ /* This is an Scheme48/C interface file, ** automatically generated by a hacked version of cig 3.0. -step 3 +step 4 */ #include diff --git a/scsh/time.scm b/scsh/time.scm index 2b3bab2..5c16b23 100644 --- a/scsh/time.scm +++ b/scsh/time.scm @@ -10,6 +10,8 @@ ;;; - If tz-name not defined, fabbed from tz-secs. ;;; - If tz-secs not defined, filled in from tz-name. +(foreign-init-name "time") + (foreign-source "#include \"time1.h\"" ; Import the time1.h interface. "") diff --git a/scsh/tty.c b/scsh/tty.c index e2b0689..7844656 100644 --- a/scsh/tty.c +++ b/scsh/tty.c @@ -1,6 +1,6 @@ /* This is an Scheme48/C interface file, ** automatically generated by a hacked version of cig 3.0. -step 3 +step 4 */ #include @@ -51,6 +51,18 @@ s48_value df_scheme_tcgetattr(s48_value g1, s48_value g2, s48_value mv_vec) return ret1; } +s48_value df_scheme_tcgetattrB(s48_value g1, s48_value g2, s48_value g3) +{ + extern int scheme_tcgetattrB(int , char *, s48_value ); + s48_value ret1; + int r1; + + + r1 = scheme_tcgetattrB(s48_extract_fixnum(g1), s48_extract_string(g2), g3); + ret1 = errno_or_false(r1); + return ret1; +} + s48_value df_scheme_tcsetattr(s48_value g1, s48_value g2, s48_value g3, s48_value g4, s48_value g5, s48_value g6, s48_value g7, s48_value g8, s48_value g9, s48_value g10, s48_value g11, s48_value g12, s48_value g13, s48_value g14, s48_value g15) { extern int scheme_tcsetattr(int , int , const char *, int , int , int , int , int , int , int , int , int , int , int , int ); @@ -190,6 +202,7 @@ s48_value df_scm_ctermid(s48_value mv_vec) s48_value s48_init_tty(void) { S48_EXPORT_FUNCTION(df_scheme_tcgetattr); + S48_EXPORT_FUNCTION(df_scheme_tcgetattrB); S48_EXPORT_FUNCTION(df_scheme_tcsetattr); S48_EXPORT_FUNCTION(df_tcsendbreak); S48_EXPORT_FUNCTION(df_tcdrain); diff --git a/scsh/tty.scm b/scsh/tty.scm index 2440ea0..b5abdd7 100644 --- a/scsh/tty.scm +++ b/scsh/tty.scm @@ -13,6 +13,8 @@ ;;; Copyright (c) 1995 by Brian D. Carlstrom. ;;; Rehacked by Olin 8/95. +(foreign-init-name "tty") + (foreign-source "#include " "" diff --git a/scsh/tty1.c b/scsh/tty1.c index 1837b94..19670b0 100644 --- a/scsh/tty1.c +++ b/scsh/tty1.c @@ -16,6 +16,7 @@ #include #include #include +#include "scheme48.h" /* This #include is for the #ifdef'd code in open_ctty() below, and ** is therefor ifdef'd identically. @@ -53,6 +54,29 @@ int scheme_tcgetattr(int fd, char *control_chars, return result; } +int scheme_tcgetattrB(int fd, char *control_chars, s48_value scmvec) +{ + struct termios t; + int result = tcgetattr(fd, &t); + // JMG int *ivec = ADDRESS_AFTER_HEADER(scmvec, int); + + if (result != -1) { + memcpy(control_chars, t.c_cc, NCCS); + S48_VECTOR_SET(scmvec, 0, s48_enter_fixnum(t.c_iflag >> 24)); + S48_VECTOR_SET(scmvec, 1, s48_enter_fixnum(t.c_iflag & 0xffffff)); + S48_VECTOR_SET(scmvec, 2, s48_enter_fixnum(t.c_oflag >> 24)); + S48_VECTOR_SET(scmvec, 3, s48_enter_fixnum(t.c_oflag & 0xffffff)); + S48_VECTOR_SET(scmvec, 4, s48_enter_fixnum(t.c_cflag >> 24)); + S48_VECTOR_SET(scmvec, 5, s48_enter_fixnum(t.c_cflag & 0xffffff)); + S48_VECTOR_SET(scmvec, 6, s48_enter_fixnum(t.c_lflag >> 24)); + S48_VECTOR_SET(scmvec, 7, s48_enter_fixnum(t.c_lflag & 0xffffff)); + S48_VECTOR_SET(scmvec, 8, s48_enter_fixnum(cfgetispeed(&t))); + S48_VECTOR_SET(scmvec, 9, s48_enter_fixnum(cfgetospeed(&t))); + } + + return result; + } + /*****************************************************************************/ diff --git a/scsh/utilities.scm b/scsh/utilities.scm index 89398a5..fbb4cab 100644 --- a/scsh/utilities.scm +++ b/scsh/utilities.scm @@ -89,6 +89,15 @@ (define any? first?) + +(define (every pred list) + (or (not (pair? list)) + (let lp ((head (car list)) (tail (cdr list))) + (if (pair? tail) + (and (pred head) (lp (car tail) (cdr tail))) + (pred head))))) ; Tail-call the last PRED call. + + (define (every? pred list) (letrec ((lp (lambda (list) (or (not (pair? list))