From: Chris Hanson Date: Tue, 18 Dec 2001 18:40:07 +0000 (+0000) Subject: Restructure packaging so that all runtime-system packages inherit from X-Git-Tag: 20090517-FFI~2395 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=92be89b5d4bea209e785959f6d376a7f1e6f8101;p=mit-scheme.git Restructure packaging so that all runtime-system packages inherit from the (RUNTIME) package. We will use the latter as a place to attach the syntax from SYNTAX-TABLE/SYSTEM-INTERNAL. --- diff --git a/v7/src/runtime/bitstr.scm b/v7/src/runtime/bitstr.scm index 0a268c7ea..622bd42d7 100644 --- a/v7/src/runtime/bitstr.scm +++ b/v7/src/runtime/bitstr.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: bitstr.scm,v 14.3 1999/01/02 06:11:34 cph Exp $ +$Id: bitstr.scm,v 14.4 2001/12/18 18:39:17 cph Exp $ -Copyright (c) 1988, 1999 Massachusetts Institute of Technology +Copyright (c) 1988, 1999, 2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,24 +16,25 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Bit String Primitives -;;; package: () +;;; package: (runtime bit-string) (declare (usual-integrations)) (define-primitives - bit-string-allocate make-bit-string bit-string? - bit-string-length bit-string-ref bit-string-clear! bit-string-set! - bit-string-zero? bit-string=? - bit-string-fill! bit-string-move! bit-string-movec! - bit-string-or! bit-string-and! bit-string-andc! - bit-string-xor! bit-substring-move-right! - bit-string->unsigned-integer unsigned-integer->bit-string - read-bits! write-bits! - bit-substring-find-next-set-bit) + bit-string-allocate make-bit-string bit-string? + bit-string-length bit-string-ref bit-string-clear! bit-string-set! + bit-string-zero? bit-string=? + bit-string-fill! bit-string-move! bit-string-movec! + bit-string-or! bit-string-and! bit-string-andc! + bit-string-xor! bit-substring-move-right! + bit-string->unsigned-integer unsigned-integer->bit-string + read-bits! write-bits! + bit-substring-find-next-set-bit) (define (bit-string-copy bit-string) (let ((result (bit-string-allocate (bit-string-length bit-string)))) diff --git a/v7/src/runtime/blowfish.scm b/v7/src/runtime/blowfish.scm index 06ec0cbec..9fe317ebc 100644 --- a/v7/src/runtime/blowfish.scm +++ b/v7/src/runtime/blowfish.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: blowfish.scm,v 1.23 2001/03/08 19:27:33 cph Exp $ +$Id: blowfish.scm,v 1.24 2001/12/18 18:39:19 cph Exp $ Copyright (c) 1997-2001 Massachusetts Institute of Technology @@ -16,11 +16,12 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Interface to Blowfish -;;; package: () +;;; package: (runtime blowfish) (declare (usual-integrations)) diff --git a/v7/src/runtime/boole.scm b/v7/src/runtime/boole.scm index 7bbf78512..7e40f775b 100644 --- a/v7/src/runtime/boole.scm +++ b/v7/src/runtime/boole.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: boole.scm,v 14.3 1999/01/02 06:11:34 cph Exp $ +$Id: boole.scm,v 14.4 2001/12/18 18:39:22 cph Exp $ -Copyright (c) 1988, 1999 Massachusetts Institute of Technology +Copyright (c) 1988, 1999, 2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,46 +16,54 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Boolean Operations -;;; package: () +;;; package: (runtime boolean) (declare (usual-integrations)) - + (define-primitives not (false? not)) -(define false #F) -(define true #T) +(define false #f) +(define true #t) (define (boolean? object) - (or (eq? object #F) - (eq? object #T))) + (or (eq? object #f) + (eq? object #t))) (define (boolean=? x y) (if x y (not y))) (define (boolean/or . arguments) (let loop ((arguments arguments)) - (cond ((null? arguments) false) - ((car arguments) true) - (else (loop (cdr arguments)))))) + (if (pair? arguments) + (if (car arguments) + #t + (loop (cdr arguments))) + #f))) (define (boolean/and . arguments) (let loop ((arguments arguments)) - (cond ((null? arguments) true) - ((car arguments) (loop (cdr arguments))) - (else false)))) + (if (pair? arguments) + (if (car arguments) + (loop (cdr arguments)) + #f) + #t))) (define (there-exists? items predicate) (let loop ((items items)) - (and (not (null? items)) - (or (predicate (car items)) - (loop (cdr items)))))) + (if (pair? items) + (or (predicate (car items)) + (loop (cdr items))) + #f))) (define (for-all? items predicate) (let loop ((items items)) - (or (null? items) - (and (predicate (car items)) - (loop (cdr items)))))) \ No newline at end of file + (if (pair? items) + (if (predicate (car items)) + (loop (cdr items)) + #f) + #t))) \ No newline at end of file diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm index 659c1ebe3..bf31351bb 100644 --- a/v7/src/runtime/boot.scm +++ b/v7/src/runtime/boot.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: boot.scm,v 14.12 1999/01/02 06:11:34 cph Exp $ +$Id: boot.scm,v 14.13 2001/12/18 18:39:24 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,11 +16,12 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Boot Time Definitions -;;; package: () +;;; package: (runtime boot-definitions) (declare (usual-integrations)) diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm index 7cd66d0cf..5aade4f00 100644 --- a/v7/src/runtime/ed-ffi.scm +++ b/v7/src/runtime/ed-ffi.scm @@ -1,6 +1,6 @@ #| -*- Scheme -*- -$Id: ed-ffi.scm,v 1.30 2001/11/11 05:58:39 cph Exp $ +$Id: ed-ffi.scm,v 1.31 2001/12/18 18:39:26 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -25,302 +25,149 @@ USA. (declare (usual-integrations)) (standard-scheme-find-file-initialization - '#( - ("advice" (runtime advice) - syntax-table/system-internal) - ("apply" (runtime apply) - syntax-table/system-internal) - ("apropos" (runtime apropos) - syntax-table/system-internal) - ("arith" (runtime number) - syntax-table/system-internal) - ("bitstr" () - syntax-table/system-internal) - ("blowfish" () - syntax-table/system-internal) - ("boole" () - syntax-table/system-internal) - ("boot" () - syntax-table/system-internal) - ("char" (runtime character) - syntax-table/system-internal) - ("chrset" (runtime character-set) - syntax-table/system-internal) - ("chrsyn" (runtime char-syntax) - syntax-table/system-internal) - ("codwlk" (runtime scode-walker) - syntax-table/system-internal) - ("conpar" (runtime continuation-parser) - syntax-table/system-internal) - ("contin" (runtime continuation) - syntax-table/system-internal) - ("cpoint" (runtime control-point) - syntax-table/system-internal) - ("cpress" (runtime compress) - syntax-table/system-internal) - ("crypto" (runtime crypto) - syntax-table/system-internal) - ("datime" (runtime date/time) - syntax-table/system-internal) - ("dbgcmd" (runtime debugger-command-loop) - syntax-table/system-internal) - ("dbgutl" (runtime debugger-utilities) - syntax-table/system-internal) - ("debug" (runtime debugger) - syntax-table/system-internal) - ("defstr" (runtime defstruct) - syntax-table/system-internal) - ("dosdir" (runtime directory) - syntax-table/system-internal) - ("dosprm" () - syntax-table/system-internal) - ("dosproc" () - syntax-table/system-internal) - ("dospth" (runtime pathname dos) - syntax-table/system-internal) - ("dragon4" (runtime number) - syntax-table/system-internal) - ("emacs" (runtime emacs-interface) - syntax-table/system-internal) - ("equals" () - syntax-table/system-internal) - ("error" (runtime error-handler) - syntax-table/system-internal) - ("events" (runtime event-distributor) - syntax-table/system-internal) - ("fileio" (runtime file-i/o-port) - syntax-table/system-internal) - ("fixart" () - syntax-table/system-internal) - ("format" (runtime format) - syntax-table/system-internal) - ("framex" (runtime debugging-info) - syntax-table/system-internal) - ("gc" (runtime garbage-collector) - syntax-table/system-internal) - ("gcdemn" (runtime gc-daemons) - syntax-table/system-internal) - ("gcfinal" (runtime gc-finalizer) - syntax-table/system-internal) - ("gcnote" (runtime gc-notification) - syntax-table/system-internal) - ("gcstat" (runtime gc-statistics) - syntax-table/system-internal) - ("gdatab" (runtime global-database) - syntax-table/system-internal) - ("gdbm" (runtime gdbm) - syntax-table/system-internal) - ("gencache" (runtime generic-procedure) - syntax-table/system-internal) - ("geneqht" (runtime generic-procedure) - syntax-table/system-internal) - ("generic" (runtime generic-procedure) - syntax-table/system-internal) - ("genio" (runtime generic-i/o-port) - syntax-table/system-internal) - ("genmult" (runtime generic-procedure multiplexer) - syntax-table/system-internal) - ("gensym" (runtime gensym) - syntax-table/system-internal) - ("gentag" (runtime generic-procedure) - syntax-table/system-internal) - ("global" () - syntax-table/system-internal) - ("graphics" (runtime graphics) - syntax-table/system-internal) - ("hash" (runtime hash) - syntax-table/system-internal) - ("hashtb" (runtime hash-table) - syntax-table/system-internal) - ("histry" (runtime history) - syntax-table/system-internal) - ("illdef" (runtime illegal-definitions) - syntax-table/system-internal) - ("infstr" (runtime compiler-info) - syntax-table/system-internal) - ("infutl" (runtime compiler-info) - syntax-table/system-internal) - ("input" (runtime input-port) - syntax-table/system-internal) - ("intrpt" (runtime interrupt-handler) - syntax-table/system-internal) - ("io" (runtime primitive-io) - syntax-table/system-internal) - ("krypt" (runtime krypt) - syntax-table/system-internal) - ("kryptdum" (runtime krypt) - syntax-table/system-internal) - ("lambda" (runtime lambda-abstraction) - syntax-table/system-internal) - ("lambdx" () - syntax-table/system-internal) - ("list" (runtime list) - syntax-table/system-internal) - ("load" (runtime load) - syntax-table/system-internal) - ("macros" (runtime macros) - syntax-table/system-internal) - ("mime-codec" (runtime mime-codec) - syntax-table/system-internal) - ("msort" () - syntax-table/system-internal) - ("ntdir" (runtime directory) - syntax-table/system-internal) - ("ntprm" () - syntax-table/system-internal) - ("numint" (runtime number interface) - syntax-table/system-internal) - ("numpar" (runtime number-parser) - syntax-table/system-internal) - ("option" (runtime options) - syntax-table/system-internal) - ("ordvec" (runtime ordered-vector) - syntax-table/system-internal) - ("os2ctype" (runtime os2-graphics) - syntax-table/system-internal) - ("os2dir" (runtime directory) - syntax-table/system-internal) - ("os2graph" (runtime os2-graphics) - syntax-table/system-internal) - ("os2prm" () - syntax-table/system-internal) - ("os2winp" (runtime os2-window-primitives) - syntax-table/system-internal) - ("output" (runtime output-port) - syntax-table/system-internal) - ("packag" (package) - syntax-table/system-internal) - ("parse" (runtime parser) - syntax-table/system-internal) - ("parser-buffer" (runtime parser-buffer) - syntax-table/system-internal) - ("partab" (runtime parser-table) - syntax-table/system-internal) - ("pathnm" (runtime pathname) - syntax-table/system-internal) - ("poplat" (runtime population) - syntax-table/system-internal) - ("port" (runtime port) - syntax-table/system-internal) - ("pp" (runtime pretty-printer) - syntax-table/system-internal) - ("prgcop" (runtime program-copier) - syntax-table/system-internal) - ("process" (runtime subprocess) - syntax-table/system-internal) - ("prop1d" (runtime 1d-property) - syntax-table/system-internal) - ("prop2d" (runtime 2D-property) - syntax-table/system-internal) - ("qsort" () - syntax-table/system-internal) - ("queue" () - syntax-table/system-internal) - ("random" (runtime random-number) - syntax-table/system-internal) - ("rbtree" (runtime rb-tree) - syntax-table/system-internal) - ("record" (runtime record) - syntax-table/system-internal) - ("recslot" (runtime record-slot-access) - syntax-table/system-internal) - ("regexp" (runtime regular-expression) - syntax-table/system-internal) - ("rep" (runtime rep) - syntax-table/system-internal) - ("rexp" (runtime rexp) - syntax-table/system-internal) - ("rgxcmp" (runtime regular-expression-compiler) - syntax-table/system-internal) - ("savres" (runtime save/restore) - syntax-table/system-internal) - ("scan" (runtime scode-scan) - syntax-table/system-internal) - ("scode" (runtime scode) - syntax-table/system-internal) - ("scomb" (runtime scode-combinator) - syntax-table/system-internal) - ("sdata" (runtime scode-data) - syntax-table/system-internal) - ("sfile" () - syntax-table/system-internal) - ("socket" (runtime socket) - syntax-table/system-internal) - ("starbase" (runtime starbase-graphics) - syntax-table/system-internal) - ("stream" (runtime stream) - syntax-table/system-internal) - ("string" (runtime string) - syntax-table/system-internal) - ("strnin" (runtime string-input) - syntax-table/system-internal) - ("strott" (runtime truncated-string-output) - syntax-table/system-internal) - ("strout" (runtime string-output) - syntax-table/system-internal) - ("symbol" () - syntax-table/system-internal) - ("syncproc" (runtime synchronous-subprocess) - syntax-table/system-internal) - ("syntab" (runtime syntax-table) - syntax-table/system-internal) - ("syntax" (runtime syntaxer) - syntax-table/system-internal) - ("sysclk" (runtime system-clock) - syntax-table/system-internal) - ("sysmac" (runtime system-macros) - syntax-table/system-internal) - ("system" (runtime system) - syntax-table/system-internal) - ("thread" (runtime thread) - syntax-table/system-internal) - ("tscript" (runtime transcript) - syntax-table/system-internal) - ("ttyio" (runtime console-i/o-port) - syntax-table/system-internal) - ("tvector" (runtime tagged-vector) - syntax-table/system-internal) - ("udata" () - syntax-table/system-internal) - ("uenvir" (runtime environment) - syntax-table/system-internal) - ("uerror" (runtime microcode-errors) - syntax-table/system-internal) - ("unicode" (runtime unicode) - syntax-table/system-internal) - ("unpars" (runtime unparser) - syntax-table/system-internal) - ("unsyn" (runtime unsyntaxer) - syntax-table/system-internal) - ("unxdir" (runtime directory) - syntax-table/system-internal) - ("unxprm" () - syntax-table/system-internal) - ("unxpth" (runtime pathname unix) - syntax-table/system-internal) - ("uproc" (runtime procedure) - syntax-table/system-internal) - ("urtrap" (runtime reference-trap) - syntax-table/system-internal) - ("usrint" (runtime user-interface) - syntax-table/system-internal) - ("utabs" (runtime microcode-tables) - syntax-table/system-internal) - ("vector" () - syntax-table/system-internal) - ("version" (runtime) - syntax-table/system-internal) - ("where" (runtime environment-inspector) - syntax-table/system-internal) - ("wind" (runtime state-space) - syntax-table/system-internal) - ("wrkdir" (runtime working-directory) - syntax-table/system-internal) - ("wttree" (runtime wt-tree) - syntax-table/system-internal) - ("x11graph" (runtime X-graphics) - syntax-table/system-internal) - ("xeval" (runtime extended-scode-eval) - syntax-table/system-internal) - ("ystep" (runtime stepper) - syntax-table/system-internal))) \ No newline at end of file + '#(("advice" (runtime advice)) + ("apply" (runtime apply)) + ("apropos" (runtime apropos)) + ("arith" (runtime number)) + ("bitstr" (runtime bit-string)) + ("blowfish" (runtime blowfish)) + ("boole" (runtime boolean)) + ("boot" (runtime boot-definitions)) + ("char" (runtime character)) + ("chrset" (runtime character-set)) + ("chrsyn" (runtime char-syntax)) + ("codwlk" (runtime scode-walker)) + ("conpar" (runtime continuation-parser)) + ("contin" (runtime continuation)) + ("cpoint" (runtime control-point)) + ("cpress" (runtime compress)) + ("crypto" (runtime crypto)) + ("datime" (runtime date/time)) + ("dbgcmd" (runtime debugger-command-loop)) + ("dbgutl" (runtime debugger-utilities)) + ("debug" (runtime debugger)) + ("defstr" (runtime defstruct)) + ("dospth" (runtime pathname dos)) + ("dragon4" (runtime number)) + ("emacs" (runtime emacs-interface)) + ("equals" (runtime equality)) + ("error" (runtime error-handler)) + ("events" (runtime event-distributor)) + ("fileio" (runtime file-i/o-port)) + ("fixart" (runtime fixnum-arithmetic)) + ("format" (runtime format)) + ("framex" (runtime debugging-info)) + ("gc" (runtime garbage-collector)) + ("gcdemn" (runtime gc-daemons)) + ("gcfinal" (runtime gc-finalizer)) + ("gcnote" (runtime gc-notification)) + ("gcstat" (runtime gc-statistics)) + ("gdatab" (runtime global-database)) + ("gdbm" (runtime gdbm)) + ("gencache" (runtime generic-procedure)) + ("geneqht" (runtime generic-procedure)) + ("generic" (runtime generic-procedure)) + ("genio" (runtime generic-i/o-port)) + ("genmult" (runtime generic-procedure multiplexer)) + ("gensym" (runtime gensym)) + ("gentag" (runtime generic-procedure)) + ("global" (runtime miscellaneous-global)) + ("graphics" (runtime graphics)) + ("hash" (runtime hash)) + ("hashtb" (runtime hash-table)) + ("histry" (runtime history)) + ("illdef" (runtime illegal-definitions)) + ("infstr" (runtime compiler-info)) + ("infutl" (runtime compiler-info)) + ("input" (runtime input-port)) + ("intrpt" (runtime interrupt-handler)) + ("io" (runtime primitive-io)) + ("krypt" (runtime krypt)) + ("kryptdum" (runtime krypt)) + ("lambda" (runtime lambda-abstraction)) + ("lambdx" (runtime alternative-lambda)) + ("list" (runtime list)) + ("load" (runtime load)) + ("macros" (runtime macros)) + ("mime-codec" (runtime mime-codec)) + ("msort" (runtime merge-sort)) + ("ntdir" (runtime directory)) + ("ntprm" (runtime os-primitives)) + ("numint" (runtime number interface)) + ("numpar" (runtime number-parser)) + ("option" (runtime options)) + ("ordvec" (runtime ordered-vector)) + ("os2ctype" (runtime os2-graphics)) + ("os2dir" (runtime directory)) + ("os2graph" (runtime os2-graphics)) + ("os2prm" (runtime os-primitives)) + ("os2winp" (runtime os2-window-primitives)) + ("output" (runtime output-port)) + ("packag" (package)) + ("parse" (runtime parser)) + ("parser-buffer" (runtime parser-buffer)) + ("partab" (runtime parser-table)) + ("pathnm" (runtime pathname)) + ("poplat" (runtime population)) + ("port" (runtime port)) + ("pp" (runtime pretty-printer)) + ("prgcop" (runtime program-copier)) + ("process" (runtime subprocess)) + ("prop1d" (runtime 1d-property)) + ("prop2d" (runtime 2D-property)) + ("qsort" (runtime quick-sort)) + ("queue" (runtime simple-queue)) + ("random" (runtime random-number)) + ("rbtree" (runtime rb-tree)) + ("record" (runtime record)) + ("recslot" (runtime record-slot-access)) + ("regexp" (runtime regular-expression)) + ("rep" (runtime rep)) + ("rexp" (runtime rexp)) + ("rgxcmp" (runtime regular-expression-compiler)) + ("savres" (runtime save/restore)) + ("scan" (runtime scode-scan)) + ("scode" (runtime scode)) + ("scomb" (runtime scode-combinator)) + ("sdata" (runtime scode-data)) + ("sfile" (runtime simple-file-ops)) + ("socket" (runtime socket)) + ("starbase" (runtime starbase-graphics)) + ("stream" (runtime stream)) + ("string" (runtime string)) + ("strnin" (runtime string-input)) + ("strott" (runtime truncated-string-output)) + ("strout" (runtime string-output)) + ("symbol" (runtime symbol)) + ("syncproc" (runtime synchronous-subprocess)) + ("syntab" (runtime syntax-table)) + ("syntax" (runtime syntaxer)) + ("sysclk" (runtime system-clock)) + ("sysmac" (runtime system-macros)) + ("system" (runtime system)) + ("thread" (runtime thread)) + ("tscript" (runtime transcript)) + ("ttyio" (runtime console-i/o-port)) + ("tvector" (runtime tagged-vector)) + ("udata" (runtime microcode-data)) + ("uenvir" (runtime environment)) + ("uerror" (runtime microcode-errors)) + ("unicode" (runtime unicode)) + ("unpars" (runtime unparser)) + ("unsyn" (runtime unsyntaxer)) + ("unxdir" (runtime directory)) + ("unxprm" (runtime os-primitives)) + ("unxpth" (runtime pathname unix)) + ("uproc" (runtime procedure)) + ("urtrap" (runtime reference-trap)) + ("usrint" (runtime user-interface)) + ("utabs" (runtime microcode-tables)) + ("vector" (runtime vector)) + ("version" (runtime)) + ("where" (runtime environment-inspector)) + ("wind" (runtime state-space)) + ("wrkdir" (runtime working-directory)) + ("wttree" (runtime wt-tree)) + ("x11graph" (runtime X-graphics)) + ("xeval" (runtime extended-scode-eval)) + ("ystep" (runtime stepper)))) \ No newline at end of file diff --git a/v7/src/runtime/equals.scm b/v7/src/runtime/equals.scm index 6d4fbc54c..3d1dfa600 100644 --- a/v7/src/runtime/equals.scm +++ b/v7/src/runtime/equals.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: equals.scm,v 14.8 1999/01/02 06:11:34 cph Exp $ +$Id: equals.scm,v 14.9 2001/12/18 18:39:29 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,11 +16,12 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Equality -;;; package: () +;;; package: (runtime equality) (declare (usual-integrations)) @@ -68,7 +69,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ((pathname? x) (and (pathname? y) (pathname=? x y))) - (else false)) + (else #f)) (and (number? x) (number? y) (= x y) diff --git a/v7/src/runtime/fixart.scm b/v7/src/runtime/fixart.scm index ef2101fd9..b214129dc 100644 --- a/v7/src/runtime/fixart.scm +++ b/v7/src/runtime/fixart.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: fixart.scm,v 1.7 2001/10/22 00:28:09 cph Exp $ +$Id: fixart.scm,v 1.8 2001/12/18 18:39:31 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -21,7 +21,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA |# ;;;; Fixnum Arithmetic -;;; package: () +;;; package: (runtime fixnum-arithmetic) (declare (usual-integrations)) diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index e955003cc..2726a1585 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: global.scm,v 14.54 2001/10/02 18:51:54 cph Exp $ +$Id: global.scm,v 14.55 2001/12/18 18:39:33 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -21,14 +21,14 @@ USA. |# ;;;; Miscellaneous Global Definitions -;;; package: () +;;; package: (runtime miscellaneous-global) (declare (usual-integrations)) ;;;; Primitive Operators (define-primitives - force error-procedure + error-procedure set-interrupt-enables! enable-interrupts! with-interrupt-mask get-fixed-objects-vector with-history-disabled (primitive-procedure-arity 1) @@ -71,17 +71,15 @@ USA. (define (identity-procedure x) x) (define (null-procedure . args) args '()) -(define (false-procedure . args) args false) -(define (true-procedure . args) args true) +(define (false-procedure . args) args #f) +(define (true-procedure . args) args #t) ;; This definition is replaced when the ;; later in the boot sequence. (define apply (ucode-primitive apply 2)) (define (eval expression environment) - (extended-scode-eval (syntax expression - (environment-syntax-table environment)) - environment)) + (extended-scode-eval (syntax expression environment) environment)) (define (scode-eval scode environment) (hook/scode-eval scode environment)) @@ -99,13 +97,13 @@ USA. (lambda () (set! old-value (get-component object)) (set-component! object new-value) - (set! new-value false) + (set! new-value #f) unspecific) thunk (lambda () (set! new-value (get-component object)) (set-component! object old-value) - (set! old-value false) + (set! old-value #f) unspecific))))) (define (bind-cell-contents! cell new-value thunk) @@ -192,7 +190,7 @@ USA. (wait-loop))))) (define (exit #!optional integer) - (hook/exit (if (default-object? integer) false integer))) + (hook/exit (if (default-object? integer) #f integer))) (define (default/exit integer) (if (prompt-for-confirmation "Kill Scheme") @@ -218,10 +216,12 @@ USA. (define hook/quit default/quit) (define syntaxer/default-environment - (let () (the-environment))) + (*make-environment system-global-environment + (vector lambda-tag:unnamed))) (define user-initial-environment - (let () (the-environment))) + (*make-environment system-global-environment + (vector lambda-tag:unnamed))) (define user-initial-prompt "]=>") @@ -261,7 +261,7 @@ USA. (if ((ucode-primitive primitive-fasdump) object filename (if (default-object? dump-option) - false + #f dump-option)) (end-message) (begin @@ -312,6 +312,6 @@ USA. (let per-symbol ((bucket (vector-ref obarray index)) (accumulator accumulator)) - (if (null? bucket) - (per-bucket (fix:- index 1) accumulator) - (per-symbol (cdr bucket) (cons (car bucket) accumulator)))))))) \ No newline at end of file + (if (pair? bucket) + (per-symbol (cdr bucket) (cons (car bucket) accumulator)) + (per-bucket (fix:- index 1) accumulator))))))) \ No newline at end of file diff --git a/v7/src/runtime/lambdx.scm b/v7/src/runtime/lambdx.scm index 61fdea210..874997faa 100644 --- a/v7/src/runtime/lambdx.scm +++ b/v7/src/runtime/lambdx.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: lambdx.scm,v 14.9 2000/10/14 00:56:20 cph Exp $ +$Id: lambdx.scm,v 14.10 2001/12/18 18:39:35 cph Exp $ -Copyright (c) 1988-2000 Massachusetts Institute of Technology +Copyright (c) 1988-2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,14 +16,15 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Alternative Components for Lambda -;;; package: () +;;; package: (runtime alternative-lambda) (declare (usual-integrations)) - + (define (make-lambda* name required optional rest body) (scan-defines body @@ -40,25 +41,24 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (lambda-components* *lambda (lambda (name required optional rest body) (receiver (make-lambda-pattern name required optional rest) - (append required optional (if (false? rest) '() (list rest))) + (append required optional (if rest (list rest) '())) body)))) (define-structure (lambda-pattern (conc-name lambda-pattern/)) - (name false read-only true) - (required false read-only true) - (optional false read-only true) - (rest false read-only true)) + (name #f read-only #t) + (required #f read-only #t) + (optional #f read-only #t) + (rest #f read-only #t)) (define (make-lambda** pattern bound body) (define (split pattern bound receiver) - (cond ((null? pattern) - (receiver '() bound)) - (else - (split (cdr pattern) (cdr bound) - (lambda (copy tail) - (receiver (cons (car bound) copy) - tail)))))) + (if (pair? pattern) + (split (cdr pattern) (cdr bound) + (lambda (copy tail) + (receiver (cons (car bound) copy) + tail))) + (receiver '() bound))) (split (lambda-pattern/required pattern) bound (lambda (required tail) @@ -67,5 +67,5 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (make-lambda* (lambda-pattern/name pattern) required optional - (if (null? rest) #F (car rest)) + (if (pair? rest) (car rest) #f) body)))))) \ No newline at end of file diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 95c521eee..fe64e9a07 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.74 2001/12/18 18:27:24 cph Exp $ +$Id: make.scm,v 14.75 2001/12/18 18:39:38 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -438,7 +438,7 @@ USA. ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-CONDITIONS! #t) ((RUNTIME STREAM) INITIALIZE-CONDITIONS! #t) ;; System dependent stuff - (() INITIALIZE-SYSTEM-PRIMITIVES! #f) + ((RUNTIME OS-PRIMITIVES) INITIALIZE-SYSTEM-PRIMITIVES! #t) ;; Threads (RUNTIME THREAD) ;; I/O diff --git a/v7/src/runtime/msort.scm b/v7/src/runtime/msort.scm index afd2a511c..6f5ad6fbf 100644 --- a/v7/src/runtime/msort.scm +++ b/v7/src/runtime/msort.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: msort.scm,v 14.8 2001/11/26 19:11:18 cph Exp $ +$Id: msort.scm,v 14.9 2001/12/18 18:39:40 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -21,7 +21,7 @@ along with this program; if not, write to the Free Software |# ;;;; Merge Sort -;;; package: () +;;; package: (runtime merge-sort) (declare (usual-integrations)) diff --git a/v7/src/runtime/ntprm.scm b/v7/src/runtime/ntprm.scm index b7d1c200f..9be3d2646 100644 --- a/v7/src/runtime/ntprm.scm +++ b/v7/src/runtime/ntprm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ntprm.scm,v 1.36 2001/05/09 03:17:05 cph Exp $ +$Id: ntprm.scm,v 1.37 2001/12/18 18:39:42 cph Exp $ Copyright (c) 1992-2001 Massachusetts Institute of Technology @@ -21,7 +21,7 @@ USA. |# ;;;; Miscellaneous Win32 Primitives -;;; package: () +;;; package: (runtime os-primitives) (declare (usual-integrations)) @@ -409,14 +409,14 @@ USA. (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME) (let ((long-base (merge-pathnames ".mit-scheme/" (user-homedir-pathname)))) (if (dos/fs-long-filenames? long-base) - (if (null? specifier) - (directory-pathname-as-file long-base) + (if (pair? specifier) (merge-pathnames (apply string-append (cons (car specifier) (append-map (lambda (string) (list "/" string)) (cdr specifier)))) - long-base)) + long-base) + (directory-pathname-as-file long-base)) (let ((short-base (merge-pathnames "mitschem.ini/" (user-homedir-pathname)))) (let ((file-map-pathname (merge-pathnames "filemap.dat" short-base))) @@ -545,7 +545,7 @@ USA. (map (lambda (s) (fix:+ (string-length s) 1)) strings))))) (let loop ((strings strings) (index 0)) - (if (not (null? strings)) + (if (pair? strings) (let ((n (string-length (car strings)))) (substring-move! (car strings) 0 n result index) (let ((index* (fix:+ index n))) @@ -566,8 +566,7 @@ USA. quote-char escape-char)))) (define (nt/rewrite-subprocess-arguments/no-quoting strings) - (if (null? strings) - "" + (if (pair? strings) (let ((result (make-string (fix:+ (reduce + @@ -582,7 +581,8 @@ USA. (string-set! result index #\space) (substring-move! (car strings) 0 n result (fix:+ index 1)) (loop (cdr strings) (fix:+ (fix:+ index 1) n)))))) - result))) + result) + "")) (define (nt/rewrite-subprocess-arguments/quoting strings quote-char escape-char) @@ -632,7 +632,7 @@ USA. (fix:+ index 1)))))) ((fix:= i n) index)))) (let loop ((index 0) (strings strings) (analyses analyses)) - (if (not (null? strings)) + (if (pair? strings) (loop (do-arg index (car strings) (car analyses)) (cdr strings) (cdr analyses)))) @@ -653,7 +653,7 @@ USA. (file-exists? pathname) (->namestring pathname)) (let loop ((types types)) - (and (not (null? types)) + (and (pair? types) (let ((p (pathname-new-type pathname (car types)))) @@ -670,14 +670,14 @@ USA. (try-dir (directory-pathname ns)))) (if (not default-directory) (let loop ((path exec-path)) - (and (not (null? path)) + (and (pair? path) (or (and (pathname-absolute? (car path)) (try-dir (car path))) (loop (cdr path))))) (let ((default-directory (merge-pathnames default-directory))) (let loop ((path exec-path)) - (and (not (null? path)) + (and (pair? path) (or (try-dir (merge-pathnames (car path) default-directory)) diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm index 0b18d2f57..6cd4e2c19 100644 --- a/v7/src/runtime/os2prm.scm +++ b/v7/src/runtime/os2prm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: os2prm.scm,v 1.47 2001/05/09 03:17:08 cph Exp $ +$Id: os2prm.scm,v 1.48 2001/12/18 18:39:45 cph Exp $ Copyright (c) 1994-2001 Massachusetts Institute of Technology @@ -21,7 +21,7 @@ USA. |# ;;;; Miscellaneous OS/2 Primitives -;;; package: () +;;; package: (runtime os-primitives) (declare (usual-integrations)) @@ -309,14 +309,14 @@ USA. (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME) (let ((long-base (merge-pathnames ".mit-scheme/" (user-homedir-pathname)))) (if (dos/fs-long-filenames? long-base) - (if (null? specifier) - (directory-pathname-as-file long-base) + (if (pair? specifier) (merge-pathnames (apply string-append (cons (car specifier) (append-map (lambda (string) (list "/" string)) (cdr specifier)))) - long-base)) + long-base) + (directory-pathname-as-file long-base)) (let ((short-base (merge-pathnames "mitschem.ini/" (user-homedir-pathname)))) (let ((file-map-pathname (merge-pathnames "filemap.dat" short-base))) @@ -364,25 +364,26 @@ USA. (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) (let ((v (let loop ((rv select-registry-result-vectors)) - (cond ((null? rv) - (make-string os2/select-registry-lub)) - ((car rv) - => (lambda (v) (set-car! rv #f) v)) - (else - (loop (cdr rv))))))) + (if (pair? rv) + (let ((v (car rv))) + (if v + (begin + (set-car! rv #f) + v) + (loop (cdr rv)))) + (make-string os2/select-registry-lub))))) (set-interrupt-enables! interrupt-mask) v))) (define (deallocate-select-registry-result-vector v) (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) (let loop ((rv select-registry-result-vectors)) - (cond ((null? rv) - (set! select-registry-result-vectors - (cons v select-registry-result-vectors))) - ((car rv) - (loop (cdr rv))) - (else - (set-car! rv v)))) + (if (pair? rv) + (if (car rv) + (loop (cdr rv)) + (set-car! rv v)) + (set! select-registry-result-vectors + (cons v select-registry-result-vectors)))) (set-interrupt-enables! interrupt-mask)) unspecific) @@ -390,7 +391,7 @@ USA. (let ((registry (make-string os2/select-registry-lub))) (vector-8b-fill! registry 0 os2/select-registry-lub 0) (do ((descriptors descriptors (cdr descriptors))) - ((null? descriptors)) + ((not (pair? descriptors))) (add-to-select-registry! registry (car descriptors))) registry)) @@ -457,9 +458,11 @@ USA. (define (os2/rewrite-subprocess-arguments strings) (let ((strings - (cond ((null? strings) (list "" "")) - ((null? (cdr strings)) (list (car strings) "")) - (else strings)))) + (if (pair? strings) + (if (pair? (cdr strings)) + strings + (list (car strings) "")) + (list "" "")))) (let ((result (make-string (reduce + @@ -471,11 +474,11 @@ USA. (let loop ((strings (cdr strings)) (index (fix:+ n 1))) (let ((n (string-length (car strings)))) (substring-move! (car strings) 0 n result index) - (if (null? (cdr strings)) - (string-set! result (fix:+ index n) #\NUL) + (if (pair? (cdr strings)) (begin (string-set! result (fix:+ index n) #\space) - (loop (cdr strings) (fix:+ (fix:+ index n) 1))))))) + (loop (cdr strings) (fix:+ (fix:+ index n) 1))) + (string-set! result (fix:+ index n) #\NUL))))) result))) (define (os2/rewrite-subprocess-environment strings) @@ -485,7 +488,7 @@ USA. 0 (map (lambda (s) (fix:+ (string-length s) 1)) strings))))) (let loop ((strings strings) (index 0)) - (if (not (null? strings)) + (if (pair? strings) (let ((n (string-length (car strings)))) (substring-move! (car strings) 0 n result index) (string-set! result (fix:+ index n) #\NUL) @@ -507,7 +510,7 @@ USA. (file-exists? pathname) (->namestring pathname)) (let loop ((types types)) - (and (not (null? types)) + (and (pair? types) (let ((p (pathname-new-type pathname (car types)))) @@ -521,7 +524,7 @@ USA. (try program)) ((not default-directory) (let loop ((path exec-path)) - (and (not (null? path)) + (and (pair? path) (or (and (pathname-absolute? (car path)) (try-dir (car path))) (loop (cdr path)))))) @@ -529,7 +532,7 @@ USA. (let ((default-directory (merge-pathnames default-directory))) (let loop ((path exec-path)) - (and (not (null? path)) + (and (pair? path) (or (try-dir (merge-pathnames (car path) default-directory)) (loop (cdr path))))))))))) diff --git a/v7/src/runtime/qsort.scm b/v7/src/runtime/qsort.scm index 97d151695..ffe31eb8a 100644 --- a/v7/src/runtime/qsort.scm +++ b/v7/src/runtime/qsort.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: qsort.scm,v 14.4 1999/01/02 06:11:34 cph Exp $ +$Id: qsort.scm,v 14.5 2001/12/18 18:39:47 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,14 +16,15 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Quick Sort -;;; package: () +;;; package: (runtime quick-sort) (declare (usual-integrations)) - + (define (quick-sort vector predicate) (if (vector? vector) (quick-sort! (vector-copy vector) predicate) diff --git a/v7/src/runtime/queue.scm b/v7/src/runtime/queue.scm index d04b146f6..e099aeebd 100644 --- a/v7/src/runtime/queue.scm +++ b/v7/src/runtime/queue.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: queue.scm,v 14.4 1999/01/02 06:11:34 cph Exp $ +$Id: queue.scm,v 14.5 2001/12/18 18:39:49 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,11 +16,12 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Simple Queue Abstraction -;;; package: () +;;; package: (runtime simple-queue) (declare (usual-integrations)) @@ -28,38 +29,40 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (cons '() '())) (define-integrable (queue-empty? queue) - (null? (car queue))) + (not (pair? (car queue)))) (define-integrable (queued?/unsafe queue item) (memq item (car queue))) (define (enqueue!/unsafe queue object) (let ((next (cons object '()))) - (if (null? (cdr queue)) - (set-car! queue next) - (set-cdr! (cdr queue) next)) + (if (pair? (cdr queue)) + (set-cdr! (cdr queue) next) + (set-car! queue next)) (set-cdr! queue next) unspecific)) (define (dequeue!/unsafe queue) (let ((next (car queue))) - (if (null? next) + (if (not (pair? next)) (error "Attempt to dequeue from empty queue")) - (if (null? (cdr next)) - (begin (set-car! queue '()) - (set-cdr! queue '())) - (set-car! queue (cdr next))) + (if (pair? (cdr next)) + (set-car! queue (cdr next)) + (begin + (set-car! queue '()) + (set-cdr! queue '()))) (car next))) (define (queue-map!/unsafe queue procedure) (let loop () (if (not (queue-empty? queue)) - (begin (procedure (dequeue!/unsafe queue)) - (loop))))) + (begin + (procedure (dequeue!/unsafe queue)) + (loop))))) (define-integrable (queue->list/unsafe queue) (car queue)) - + ;;; Safe (interrupt locked) versions of the above operations. (define-integrable (queued? queue item) @@ -72,7 +75,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (without-interrupts (lambda () (dequeue!/unsafe queue)))) (define (queue-map! queue procedure) - (let ((empty "empty")) + (let ((empty (list 'EMPTY))) (let loop () (let ((item (without-interrupts @@ -81,8 +84,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. empty (dequeue!/unsafe queue)))))) (if (not (eq? item empty)) - (begin (procedure item) - (loop))))))) + (begin + (procedure item) + (loop))))))) (define (queue->list queue) (without-interrupts diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index f891a8452..1014ae007 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.384 2001/12/17 17:40:59 cph Exp $ +$Id: runtime.pkg,v 14.385 2001/12/18 18:39:52 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -22,27 +22,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Runtime System Packaging -(define-package () - (files "blowfish" - "bitstr" - "boole" - "boot" - "equals" - "fixart" - "global" - "lambdx" - "msort" - "qsort" - "queue" - "sfile" - "symbol" - "udata" - "vector") - (file-case os-type - ((unix) "unxprm") - ((nt) "ntprm") - ((os/2) "os2prm") - (else))) +(define-package ()) (define-package (package) ;; The information appearing here must be exactly duplicated in the @@ -77,9 +57,638 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (parent ()) (initialization (initialize-package!))) +(define-package (runtime bit-string) + (files "bitstr") + (parent (runtime)) + (export () + bit-string->signed-integer + bit-string->unsigned-integer + bit-string-allocate + bit-string-and + bit-string-and! + bit-string-andc + bit-string-andc! + bit-string-append + bit-string-append-reversed + bit-string-clear! + bit-string-copy + bit-string-fill! + bit-string-length + bit-string-move! + bit-string-movec! + bit-string-not + bit-string-or + bit-string-or! + bit-string-ref + bit-string-set! + bit-string-xor + bit-string-xor! + bit-string-zero? + bit-string=? + bit-string? + bit-substring + bit-substring-extend + bit-substring-find-next-set-bit + bit-substring-move-right! + make-bit-string + read-bits! + signed-integer->bit-string + unsigned-integer->bit-string + write-bits!)) + +(define-package (runtime blowfish) + (files "blowfish") + (parent (runtime)) + (export () + blowfish-available? + blowfish-cbc + blowfish-cfb64 + blowfish-ecb + blowfish-encrypt-port + blowfish-file? + blowfish-ofb64 + blowfish-set-key + compute-blowfish-init-vector + read-blowfish-file-header + write-blowfish-file-header)) + +(define-package (runtime boolean) + (files "boole") + (parent (runtime)) + (export () + boolean/and + boolean/or + boolean=? + boolean? + false + false? + for-all? + not + there-exists? + true)) + +(define-package (runtime boot-definitions) + (files "boot") + (parent (runtime)) + (export () + future? + get-next-constant + interrupt-bit/after-gc + interrupt-bit/gc + interrupt-bit/global-1 + interrupt-bit/global-3 + interrupt-bit/global-gc + interrupt-bit/kbd + interrupt-bit/stack + interrupt-bit/suspend + interrupt-bit/timer + interrupt-mask/all + interrupt-mask/gc-ok + interrupt-mask/no-background + interrupt-mask/none + interrupt-mask/timer-ok + object-constant? + object-pure? + standard-unparser-method + unparser-method? + unparser/standard-method + with-absolutely-no-interrupts + without-background-interrupts + without-interrupts)) + +(define-package (runtime equality) + (files "equals") + (parent (runtime)) + (export () + equal? + eqv?)) + +(define-package (runtime fixnum-arithmetic) + (files "fixart") + (parent (runtime)) + (export () + ->flonum + fix:* + fix:+ + fix:- + fix:-1+ + fix:1+ + fix:< + fix:<= + fix:= + fix:> + fix:>= + fix:and + fix:andc + fix:divide + fix:fixnum? + fix:gcd + fix:lsh + fix:max + fix:min + fix:negative? + fix:not + fix:or + fix:positive? + fix:quotient + fix:remainder + fix:xor + fix:zero? + fixnum? + flo:* + flo:+ + flo:- + flo:/ + flo:< + flo:<= + flo:= + flo:> + flo:>= + flo:abs + flo:acos + flo:asin + flo:atan + flo:atan2 + flo:ceiling + flo:ceiling->exact + flo:cos + flo:exp + flo:expt + flo:finite? + flo:flonum? + flo:floor + flo:floor->exact + flo:log + flo:max + flo:min + flo:negate + flo:negative? + flo:positive? + flo:round + flo:round->exact + flo:sin + flo:sqrt + flo:tan + flo:truncate + flo:truncate->exact + flo:vector-cons + flo:vector-length + flo:vector-ref + flo:vector-set! + flo:zero? + index-fixnum? + int:* + int:+ + int:- + int:-1+ + int:->flonum + int:1+ + int:< + int:<= + int:= + int:> + int:>= + int:divide + int:integer? + int:negate + int:negative? + int:positive? + int:quotient + int:remainder + int:zero?)) + +(define-package (runtime miscellaneous-global) + (files "global") + (parent (runtime)) + (export () + %exit + %quit + *the-non-printing-object* + apply + bind-cell-contents! + call-with-values + cd + cell-contents + cell? + default/exit + default/quit + enable-interrupts! + environment-link-name + eq? + error-procedure + eval + exit + false-procedure + fasdump + get-fixed-objects-vector + hook/exit + hook/quit + hook/scode-eval + hunk3-cons + identity-procedure + impurify + lexical-assignment + lexical-reference + lexical-unassigned? + lexical-unbound? + lexical-unreferenceable? + link-variables + local-assignment + make-cell + make-non-pointer-object + null-procedure + obarray->list + object-component-binder + object-datum + object-gc-type + object-new-type + object-non-pointer? + object-pointer? + object-type + object-type? + pa + primitive-procedure-arity + primitive-procedure-documentation + pwd + quit + scode-eval + set-cell-contents! + set-interrupt-enables! + show-time + syntaxer/default-environment + system-hunk3-cons + system-hunk3-cxr0 + system-hunk3-cxr1 + system-hunk3-cxr2 + system-hunk3-set-cxr0! + system-hunk3-set-cxr1! + system-hunk3-set-cxr2! + system-list->vector + system-pair-car + system-pair-cdr + system-pair-cons + system-pair-set-car! + system-pair-set-cdr! + system-pair? + system-subvector->list + system-vector-length + system-vector-ref + system-vector-set! + system-vector? + true-procedure + unbind-variable + undefined-value? + unspecific + user-initial-environment + user-initial-prompt + values + wait-interval + with-history-disabled + with-interrupt-mask + with-values + write-to-string)) + +(define-package (runtime alternative-lambda) + (files "lambdx") + (parent (runtime)) + (export () + lambda-components* + lambda-components** + lambda-pattern/name + lambda-pattern/optional + lambda-pattern/required + lambda-pattern/rest + lambda-pattern? + make-lambda* + make-lambda** + make-lambda-pattern)) + +(define-package (runtime merge-sort) + (files "msort") + (parent (runtime)) + (export () + merge-sort + merge-sort! + sort + sort!)) + +(define-package (runtime quick-sort) + (files "qsort") + (parent (runtime)) + (export () + quick-sort + quick-sort!)) + +(define-package (runtime simple-queue) + (files "queue") + (parent (runtime)) + (export () + make-queue + queue-empty? + queued?/unsafe + enqueue!/unsafe + dequeue!/unsafe + queue-map!/unsafe + queue->list/unsafe + queued? + enqueue! + dequeue! + queue-map! + queue->list)) + +(define-package (runtime simple-file-ops) + (files "sfile") + (parent (runtime)) + (export () + allocate-temporary-file + call-with-temporary-file-pathname + call-with-temporary-filename + current-file-time + deallocate-temporary-file + delete-directory + delete-file + delete-file-no-errors + directory-file-names + file-access + file-directory? + file-eq? + file-executable? + file-exists-direct? + file-exists-indirect? + file-exists? + file-modification-timesymbol + string->uninterned-symbol + symbol->string + symbol-append + symbol-hash + symbol-hash-mod + symbol-name + symbolblock + compiled-code-address->offset + compiled-code-address? + compiled-code-block/bytes-per-object + compiled-code-block/code-end + compiled-code-block/code-length + compiled-code-block/code-start + compiled-code-block/constants-end + compiled-code-block/constants-start + compiled-code-block/debugging-info + compiled-code-block/debugging-info? + compiled-code-block/environment + compiled-code-block/index->offset + compiled-code-block/manifest-closure? + compiled-code-block/marked-start + compiled-code-block/offset->index + compiled-code-block/read-file + compiled-code-block? + compiled-continuation/next-continuation-offset + compiled-continuation/reflect-to-interface? + compiled-continuation/return-to-interpreter? + compiled-entry-type + compiled-expression? + compiled-return-address? + discriminate-compiled-entry + environment-extension-aux-list + environment-extension-parent + environment-extension-procedure + environment-extension? + force + interpreter-return-address? + make-return-address + microcode-error + microcode-return + microcode-termination + microcode-type + promise-environment + promise-expression + promise-forced? + promise-non-expression? + promise-value + promise? + return-address/code + return-address/name + return-address? + set-compiled-code-block/debugging-info! + set-environment-extension-parent! + stack-address->index + stack-address-offset + stack-address?)) + +(define-package (runtime vector) + (files "vector") + (parent (runtime)) + (export () + for-each-vector-element + guarantee-subvector + guarantee-vector + list->vector + make-initialized-vector + make-vector + subvector + subvector->list + subvector-fill! + subvector-filled? + subvector-find-next-element + subvector-find-next-element-not + subvector-find-previous-element + subvector-find-previous-element-not + subvector-move-left! + subvector-move-right! + subvector-uniform? + vector + vector->list + vector-append + vector-binary-search + vector-copy + vector-eighth + vector-fifth + vector-fill! + vector-filled? + vector-find-next-element + vector-find-previous-element + vector-first + vector-fourth + vector-grow + vector-head + vector-length + vector-map + vector-move! + vector-of-type? + vector-ref + vector-second + vector-set! + vector-seventh + vector-sixth + vector-tail + vector-third + vector-uniform? + vector?)) + +(define-package (runtime os-primitives) + (parent (runtime)) + (export () + add-to-select-registry! + copy-file + current-home-directory + current-user-name + decode-file-time + decoded-time->file-time + encode-file-time + file-access-time + file-access-time-direct + file-access-time-indirect + file-attributes + file-attributes-direct + file-attributes-indirect + file-attributes/access-time + file-attributes/change-time + file-attributes/length + file-attributes/mode-string + file-attributes/modification-time + file-attributes/n-links + file-attributes/type + file-length + file-modes + file-modification-time + file-modification-time-direct + file-modification-time-indirect + file-time->global-decoded-time + file-time->local-decoded-time + file-time->universal-time + get-environment-variable + init-file-specifier->pathname + make-select-registry + os/default-end-of-line-translation + os/exec-path + os/executable-pathname-types + os/file-end-of-line-translation + os/find-program + os/form-shell-command + os/make-subprocess + os/parse-path-string + os/shell-file-name + remove-from-select-registry! + select-descriptor + select-registry-test + set-file-modes! + set-file-times! + temporary-directory-pathname + temporary-file-pathname + universal-time->file-time + user-home-directory) + (initialization (initialize-system-primitives!))) + +(os-type-case + ((unix) + (extend-package (runtime os-primitives) + (files "unxprm") + (export () + delete-environment-variable! + file-attributes/gid + file-attributes/inode-number + file-attributes/uid + set-environment-variable! + unix/current-gid + unix/current-pid + unix/current-uid + unix/gid->string + unix/system + unix/uid->string))) + ((nt) + (extend-package (runtime os-primitives) + (files "ntprm") + (export () + console-channel-descriptor + delete-environment-variable! + dos/fs-drive-type + dos/fs-long-filenames? + file-attributes/gid + file-attributes/inode-number + file-attributes/modes + file-attributes/uid + nt-file-mode/archive + nt-file-mode/compressed + nt-file-mode/directory + nt-file-mode/hidden + nt-file-mode/normal + nt-file-mode/read-only + nt-file-mode/system + nt-file-mode/temporary + nt-fs-flag/case-preserved-names + nt-fs-flag/case-sensitive-search + nt-fs-flag/file-compression + nt-fs-flag/persistent-acls + nt-fs-flag/unicode-on-disk + nt-fs-flag/volume-is-compressed + nt-volume-info + nt-volume-info/file-system-flags + nt-volume-info/file-system-name + nt-volume-info/max-component-length + nt-volume-info/name + nt-volume-info/serial-number + nt/hide-subprocess-windows? + nt/scheme-executable-pathname + nt/subprocess-argument-escape-char + nt/subprocess-argument-quote-char + nt/system-root-directory + nt/windows-type + set-environment-variable! + set-environment-variable-default!))) + ((os/2) + (extend-package (runtime os-primitives) + (files "os2prm") + (export () + dos/fs-drive-type + dos/fs-long-filenames? + file-attributes/allocated-length + file-attributes/modes + os2-file-mode/archived + os2-file-mode/directory + os2-file-mode/hidden + os2-file-mode/read-only + os2-file-mode/system + os2/current-pid + os2/system-root-directory)))) + (define-package (runtime string) (files "string") - (parent ()) + (parent (runtime)) (export () allocate-external-string burst-string @@ -212,7 +821,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime 1d-property) (files "prop1d") - (parent ()) + (parent (runtime)) (export () 1d-table/for-each 1d-table/alist @@ -226,7 +835,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime 2d-property) (files "prop2d") - (parent ()) + (parent (runtime)) (export () 2d-get 2d-get-alist-x @@ -237,7 +846,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime advice) (files "advice") - (parent ()) + (parent (runtime)) (export () *args* *proc* @@ -268,12 +877,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime apply) (files "apply") - (parent ()) + (parent (runtime)) (initialization (initialize-package!))) (define-package (runtime character) (files "char") - (parent ()) + (parent (runtime)) (export () ascii->char char->ascii @@ -314,7 +923,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime character-set) (files "chrset") - (parent ()) + (parent (runtime)) (export () ascii-range->char-set char-alphabetic? @@ -363,7 +972,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime compiler-info) (files "infstr" "infutl") - (parent ()) + (parent (runtime)) (export () *save-uncompressed-files?* *uncompressed-file-lifetime* @@ -431,7 +1040,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime console-i/o-port) (files "ttyio") - (parent ()) + (parent (runtime)) (export () console-i/o-port console-input-port @@ -444,7 +1053,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime continuation) (files "contin") - (parent ()) + (parent (runtime)) (export () call-with-current-continuation continuation/block-thread-events? @@ -461,7 +1070,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime continuation-parser) (files "conpar") - (parent ()) + (parent (runtime)) (export () continuation->stack-frame continuation/first-subproblem @@ -506,7 +1115,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime control-point) (files "cpoint") - (parent ()) + (parent (runtime)) (export () control-point/element-stream control-point/history @@ -522,7 +1131,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime date/time) (files "datime") - (parent ()) + (parent (runtime)) (export () ctime-string->decoded-time ctime-string->file-time @@ -592,7 +1201,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime debugger-command-loop) (files "dbgcmd") - (parent ()) + (parent (runtime)) (initialization (initialize-package!))) (define-package (runtime debugger-utilities) @@ -615,7 +1224,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime debugging-info) (files "framex") - (parent ()) + (parent (runtime)) (export () debugging-info/compiled-code? debugging-info/evaluated-object-value @@ -630,7 +1239,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime defstruct) (files "defstr") - (parent ()) + (parent (runtime)) (export () define-structure/keyword-parser define-structure/list-accessor @@ -645,26 +1254,31 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (initialization (initialize-package!))) (define-package (runtime directory) - (file-case os-type - ((unix) "unxdir") - ((os/2) "os2dir") - ((nt) "ntdir") - ;;(else "unkdir") - (else)) - (parent ()) + (parent (runtime)) (export (runtime pathname) *expand-directory-prefixes?*) (export () directory-read)) +(os-type-case + ((unix) + (extend-package (runtime directory) + (files "unxdir"))) + ((nt) + (extend-package (runtime directory) + (files "ntdir"))) + ((os/2) + (extend-package (runtime directory) + (files "os2dir")))) + (define-package (runtime emacs-interface) (files "emacs") - (parent ()) + (parent (runtime)) (initialization (initialize-package!))) (define-package (runtime procedure) (files "uproc") - (parent ()) + (parent (runtime)) (export () apply-hook-extra apply-hook-procedure @@ -701,7 +1315,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime environment) (files "uenvir") - (parent ()) + (parent (runtime)) (export () compiled-procedure/environment environment-arguments @@ -736,7 +1350,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime error-handler) (files "error") - (parent ()) + (parent (runtime)) (export () abort access-condition @@ -857,7 +1471,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime event-distributor) (files "events") - (parent ()) + (parent (runtime)) (export () add-event-receiver! event-distributor/invoke! @@ -869,7 +1483,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime extended-scode-eval) (files "xeval") - (parent ()) + (parent (runtime)) (export () extended-scode-eval hook/extended-scode-eval) @@ -877,7 +1491,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime file-i/o-port) (files "fileio") - (parent ()) + (parent (runtime)) (export () call-with-append-file call-with-binary-append-file @@ -900,7 +1514,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime transcript) (files "tscript") - (parent ()) + (parent (runtime)) (export () transcript-off transcript-on) @@ -915,14 +1529,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "format") (else)) - (parent ()) + (parent (runtime)) (export () format) (initialization (initialize-package!))) (define-package (runtime garbage-collector) (files "gc") - (parent ()) + (parent (runtime)) (export () constant-space/in-use flush-purification-queue! @@ -938,7 +1552,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime gc-daemons) (files "gcdemn") - (parent ()) + (parent (runtime)) (export () add-gc-daemon! add-gc-daemon!/no-restore @@ -957,7 +1571,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime gc-finalizer) (files "gcfinal") - (parent ()) + (parent (runtime)) (export () add-to-gc-finalizer! gc-finalizer-elements @@ -970,7 +1584,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime gc-notification) (files "gcnote") - (parent ()) + (parent (runtime)) (export () gc-statistic->string print-gc-statistics @@ -980,7 +1594,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime gc-statistics) (files "gcstat") - (parent ()) + (parent (runtime)) (export () gc-history-mode gc-statistic/heap-left @@ -1003,7 +1617,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime generic-i/o-port) (files "genio") - (parent ()) + (parent (runtime)) (export () make-generic-i/o-port make-generic-input-port @@ -1019,14 +1633,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime gensym) (files "gensym") - (parent ()) + (parent (runtime)) (export () generate-uninterned-symbol) (initialization (initialize-package!))) (define-package (runtime global-database) (files "gdatab") - (parent ()) + (parent (runtime)) (export () add-unparser-special-object! add-unparser-special-pair! @@ -1044,7 +1658,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime hash) (files "hash") - (parent ()) + (parent (runtime)) (export () hash hash-table/make @@ -1059,7 +1673,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "hashtb") (else)) - (parent ()) + (parent (runtime)) (export () eq-hash eq-hash-mod @@ -1107,7 +1721,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime history) (files "histry") - (parent ()) + (parent (runtime)) (export () with-new-history) (export (runtime continuation-parser) @@ -1121,7 +1735,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "krypt") (else)) - (parent ()) + (parent (runtime)) (export () encrypt decrypt)) @@ -1130,7 +1744,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "cpress") (else)) - (parent ()) + (parent (runtime)) (export () compress uncompress @@ -1138,7 +1752,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime port) (files "port") - (parent ()) + (parent (runtime)) (export () close-input-port close-output-port @@ -1246,7 +1860,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime input-port) (files "input") - (parent ()) + (parent (runtime)) (export () char-ready? eof-object? @@ -1273,7 +1887,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime output-port) (files "output") - (parent ()) + (parent (runtime)) (export () beep clear @@ -1298,7 +1912,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime interrupt-handler) (files "intrpt") - (parent ()) + (parent (runtime)) (export (runtime emacs-interface) hook/^G-interrupt hook/clean-input/flush-typeahead) @@ -1308,7 +1922,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime lambda-abstraction) (files "lambda") - (parent ()) + (parent (runtime)) (export () block-declaration? block-declaration-text @@ -1335,7 +1949,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime list) (files "list") - (parent ()) + (parent (runtime)) (export () add-member-procedure alist-copy @@ -1468,7 +2082,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime load) (files "load") - (parent ()) + (parent (runtime)) (export () argument-command-line-parser condition-type:not-loading @@ -1494,7 +2108,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime macros) (files "macros") - (parent ()) + (parent (runtime)) (initialization (initialize-package!))) (define-package (runtime microcode-errors) @@ -1525,7 +2139,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime microcode-tables) (files "utabs") - (parent ()) + (parent (runtime)) (export () char:newline fixed-object/code->name @@ -1569,7 +2183,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime number) (files "arith" "dragon4") - (parent ()) + (parent (runtime)) (export () * + @@ -1672,7 +2286,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime number-parser) (files "numpar") - (parent ()) + (parent (runtime)) (export () flonum-parser-fast? string->number @@ -1680,7 +2294,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime options) (files "option") - (parent ()) + (parent (runtime)) (export () *initial-options-file* declare-shared-library @@ -1694,7 +2308,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime parser) (files "parse") - (parent ()) + (parent (runtime)) (export () *parser-canonicalize-symbols?* *parser-radix* @@ -1725,7 +2339,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime parser-table) (files "partab") - (parent ()) + (parent (runtime)) (export () current-parser-table guarantee-parser-table @@ -1745,7 +2359,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime pathname) (files "pathnm") - (parent ()) + (parent (runtime)) (export () *default-pathname-defaults* ->namestring @@ -1809,7 +2423,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime population) (files "poplat") - (parent ()) + (parent (runtime)) (export () add-to-population! exists-an-inhabitant? @@ -1823,7 +2437,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime pretty-printer) (files "pp") - (parent ()) + (parent (runtime)) (export () *pp-arity-dispatched-procedure-style* *pp-auto-highlighter* @@ -1844,7 +2458,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime primitive-io) (files "io") - (parent ()) + (parent (runtime)) (export () all-open-channels channel-blocking @@ -1988,14 +2602,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime program-copier) (files "prgcop") - (parent ()) + (parent (runtime)) (export () copy-program) (initialization (initialize-package!))) (define-package (runtime random-number) (files "random") - (parent ()) + (parent (runtime)) (export () *random-state* flo:random-unit @@ -2007,7 +2621,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime record) (files "record") - (parent ()) + (parent (runtime)) (export () %make-record %record @@ -2038,7 +2652,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime reference-trap) (files "urtrap") - (parent ()) + (parent (runtime)) (export () cached-reference-trap-value cached-reference-trap? @@ -2057,7 +2671,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime rep) (files "rep") - (parent ()) + (parent (runtime)) (export () ->environment abort->nearest @@ -2156,7 +2770,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime save/restore) (files "savres") - (parent ()) + (parent (runtime)) (export () disk-restore disk-save @@ -2170,7 +2784,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime scode) (files "scode") - (parent ()) + (parent (runtime)) (export () absolute-reference-name absolute-reference-to? @@ -2231,7 +2845,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime scode-combinator) (files "scomb") - (parent ()) + (parent (runtime)) (export () combination-components combination-operands @@ -2266,7 +2880,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime scode-data) (files "sdata") - (parent ()) + (parent (runtime)) (export (runtime lambda-abstraction) &pair-car &pair-cdr @@ -2328,7 +2942,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime scode-scan) (files "scan") - (parent ()) + (parent (runtime)) (export () make-open-block open-block-components @@ -2338,7 +2952,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime scode-walker) (files "codwlk") - (parent ()) + (parent (runtime)) (export () make-scode-walker scode-walk @@ -2347,7 +2961,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime socket) (files "socket") - (parent ()) + (parent (runtime)) (export () allocate-host-address canonical-host-name @@ -2369,7 +2983,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "process") (else)) - (parent ()) + (parent (runtime)) (export () make-subprocess process-environment-bind @@ -2420,7 +3034,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "syncproc") (else)) - (parent ()) + (parent (runtime)) (export () condition-type:subprocess-abnormal-termination condition-type:subprocess-signalled @@ -2430,7 +3044,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime graphics) (files "graphics") - (parent ()) + (parent (runtime)) (export () enumerate-graphics-types graphics-bind-drawing-mode @@ -2483,7 +3097,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case os-type ((unix) "x11graph") (else)) - (parent ()) + (parent (runtime)) (export () create-x-colormap create-x-image @@ -2606,7 +3220,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case os-type ((unix) "starbase") (else)) - (parent ()) + (parent (runtime)) (export () starbase-graphics-device-type) (initialization (initialize-package!))) @@ -2615,7 +3229,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case os-type ((os/2) "os2graph" "os2ctype") (else)) - (parent ()) + (parent (runtime)) (export () os2-console/color? os2-console/get-font-metrics @@ -2638,7 +3252,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case os-type ((os/2) "os2winp") (else)) - (parent ()) + (parent (runtime)) (export (runtime os2-graphics) bbo_and bbo_ignore @@ -3051,7 +3665,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime state-space) (files "wind") - (parent ()) + (parent (runtime)) (export () dynamic-wind shallow-fluid-bind) @@ -3070,7 +3684,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime stream) (files "stream") - (parent ()) + (parent (runtime)) (export () condition-type:illegal-stream-element empty-stream? @@ -3102,7 +3716,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime string-input) (files "strnin") - (parent ()) + (parent (runtime)) (export () string->input-port with-input-from-string) @@ -3110,7 +3724,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime string-output) (files "strout") - (parent ()) + (parent (runtime)) (export () get-output-from-accumulator make-accumulator-output-port @@ -3120,7 +3734,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime syntax-table) (files "syntab") - (parent ()) + (parent (runtime)) (export () guarantee-syntax-table make-syntax-table @@ -3136,7 +3750,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime syntaxer) (files "syntax") - (parent ()) + (parent (runtime)) (export () environment-syntax-table hook/syntax-expression @@ -3161,14 +3775,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime illegal-definitions) (files "illdef") - (parent ()) + (parent (runtime)) (export (runtime syntaxer) check-for-illegal-definitions) (initialization (initialize-package!))) (define-package (runtime system) (files "system") - (parent ()) + (parent (runtime)) (export () add-identification! add-subsystem-identification! @@ -3180,7 +3794,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime system-clock) (files "sysclk") - (parent ()) + (parent (runtime)) (export () internal-time/seconds->ticks internal-time/ticks->seconds @@ -3196,21 +3810,21 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime system-macros) (files "sysmac") - (parent ()) + (parent (runtime)) (export () syntax-table/system-internal) (initialization (initialize-package!))) (define-package (runtime truncated-string-output) (files "strott") - (parent ()) + (parent (runtime)) (export () with-output-to-truncated-string) (initialization (initialize-package!))) (define-package (runtime unparser) (files "unpars") - (parent ()) + (parent (runtime)) (export () *unparse-abbreviate-quotations?* *unparse-compound-procedure-names?* @@ -3254,7 +3868,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime unsyntaxer) (files "unsyn") - (parent ()) + (parent (runtime)) (export () unsyntax unsyntax-lambda-list @@ -3263,7 +3877,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime working-directory) (files "wrkdir") - (parent ()) + (parent (runtime)) (export () set-working-directory-pathname! with-working-directory-pathname @@ -3274,7 +3888,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime user-interface) (files "usrint") - (parent ()) + (parent (runtime)) (export () prompt-for-command-char prompt-for-command-expression @@ -3300,7 +3914,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime thread) (files "thread") - (parent ()) + (parent (runtime)) (export () block-thread-events condition-type:no-current-thread @@ -3361,7 +3975,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "rbtree") (else)) - (parent ()) + (parent (runtime)) (export () alist->rb-tree make-rb-tree @@ -3394,7 +4008,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "wttree") (else)) - (parent ()) + (parent (runtime)) (export () number-wt-type string-wt-type @@ -3433,7 +4047,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime apropos) (files "apropos") - (parent ()) + (parent (runtime)) (export () apropos apropos-list)) @@ -3442,7 +4056,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "ystep") (else)) - (parent ()) + (parent (runtime)) (export () step step-form @@ -3458,7 +4072,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "ordvec") (else)) - (parent ()) + (parent (runtime)) (export () match-ordered-subvector match-ordered-vector @@ -3473,7 +4087,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "gdbm") (else)) - (parent ()) + (parent (runtime)) (export () gdbm-available? gdbm-close @@ -3500,7 +4114,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime generic-procedure) (files "gentag" "gencache" "generic") - (parent ()) + (parent (runtime)) (export () ;; tag.scm: dispatch-tag-contents @@ -3531,7 +4145,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime generic-procedure multiplexer) (files "genmult") - (parent ()) + (parent (runtime)) (export () add-generic-procedure-generator condition-type:extra-applicable-methods @@ -3544,7 +4158,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime tagged-vector) (files "tvector") - (parent ()) + (parent (runtime)) (export () guarantee-tagged-vector make-tagged-vector @@ -3560,7 +4174,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime record-slot-access) (files "recslot") - (parent ()) + (parent (runtime)) (export () condition-type:no-such-slot condition-type:slot-error @@ -3579,7 +4193,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime generic-procedure eqht) (files "geneqht") - (parent ()) + (parent (runtime)) (export (runtime generic-procedure) eqht/for-each eqht/get @@ -3588,7 +4202,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime crypto) (files "crypto") - (parent ()) + (parent (runtime)) (export () make-mhash-keygen-type mcrypt-algorithm-name @@ -3643,7 +4257,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "regexp") (else)) - (parent ()) + (parent (runtime)) (export () char-set->regexp guarantee-re-register @@ -3668,7 +4282,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "rgxcmp") (else)) - (parent ()) + (parent (runtime)) (export () compiled-regexp? compiled-regexp/byte-stream @@ -3686,7 +4300,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "rexp") (else)) - (parent ()) + (parent (runtime)) (export () rexp* rexp+ @@ -3716,7 +4330,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "chrsyn") (else)) - (parent ()) + (parent (runtime)) (export () char->syntax-code char-syntax->string @@ -3736,7 +4350,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (file-case options ((load) "mime-codec") (else)) - (parent ()) + (parent (runtime)) (export () call-with-decode-base64-output-port call-with-decode-binhex40-output-port @@ -3762,7 +4376,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime parser-buffer) (files "parser-buffer") - (parent ()) + (parent (runtime)) (export () discard-parser-buffer-head! get-parser-buffer-pointer @@ -3803,7 +4417,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime unicode) (files "unicode") - (parent ()) + (parent (runtime)) (export () 8-bit-alphabet? alphabet+ diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm index 36722f814..c6ea4913c 100644 --- a/v7/src/runtime/sfile.scm +++ b/v7/src/runtime/sfile.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: sfile.scm,v 14.31 2001/12/17 17:40:59 cph Exp $ +$Id: sfile.scm,v 14.32 2001/12/18 18:39:55 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -21,7 +21,7 @@ USA. |# ;;;; Simple File Operations -;;; package: () +;;; package: (runtime simple-file-ops) (declare (usual-integrations)) diff --git a/v7/src/runtime/symbol.scm b/v7/src/runtime/symbol.scm index cb850a4e3..c274b70ce 100644 --- a/v7/src/runtime/symbol.scm +++ b/v7/src/runtime/symbol.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: symbol.scm,v 1.5 2001/06/15 20:38:49 cph Exp $ +$Id: symbol.scm,v 1.6 2001/12/18 18:39:57 cph Exp $ Copyright (c) 1992-2001 Massachusetts Institute of Technology @@ -21,7 +21,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA |# ;;;; Symbols -;;; package: (runtime scode) +;;; package: (runtime symbol) (declare (usual-integrations)) diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm index 508229e94..82cf479bb 100644 --- a/v7/src/runtime/syntax.scm +++ b/v7/src/runtime/syntax.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: syntax.scm,v 14.33 2001/03/21 19:15:18 cph Exp $ +$Id: syntax.scm,v 14.34 2001/12/18 18:39:59 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -90,25 +90,27 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (syntax expression #!optional table) (syntax-top-level 'SYNTAX syntax-expression expression - (if (default-object? table) #f table))) + (if (default-object? table) 'DEFAULT table))) (define (syntax* expressions #!optional table) (syntax-top-level 'SYNTAX* syntax-sequence expressions - (if (default-object? table) #f table))) + (if (default-object? table) 'DEFAULT table))) (define (syntax-top-level name syntaxer expression table) (let ((scode (fluid-let ((*syntax-table* - (if table - (begin - (if (not (syntax-table? table)) - (error:wrong-type-argument table - "syntax table" - name)) - table) - (if (unassigned? *syntax-table*) - (nearest-repl/syntax-table) - *syntax-table*))) + (cond ((eq? table 'DEFAULT) + (if (unassigned? *syntax-table*) + (nearest-repl/syntax-table) + *syntax-table*)) + ((environment? table) + (environment-syntax-table table)) + (else + (if (not (syntax-table? table)) + (error:wrong-type-argument table + "syntax table" + name)) + table))) (*current-keyword* #f)) (syntaxer #t expression)))) (if *disallow-illegal-definitions?* diff --git a/v7/src/runtime/udata.scm b/v7/src/runtime/udata.scm index 38fb1e59f..bc0cb75b1 100644 --- a/v7/src/runtime/udata.scm +++ b/v7/src/runtime/udata.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: udata.scm,v 14.20 1999/03/25 03:44:20 cph Exp $ +$Id: udata.scm,v 14.21 2001/12/18 18:40:02 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,11 +16,12 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Simple Microcode Data Structures -;;; package: () +;;; package: (runtime microcode-data) (declare (usual-integrations)) @@ -243,13 +244,15 @@ contains constants derived from the source program. extension first-aux-slot (+ first-aux-slot (object-datum (vector-ref extension 2))))))) - (cond ((null? aux-list) '()) - ((unbound-reference-trap? - (map-reference-trap (lambda () (cdar aux-list)))) - (filter-potentially-dangerous (cdr aux-list))) - (else - (cons (car aux-list) - (filter-potentially-dangerous (cdr aux-list))))))) + (if (pair? aux-list) + (if (unbound-reference-trap? + (map-reference-trap + (lambda () + (cdar aux-list)))) + (filter-potentially-dangerous (cdr aux-list)) + (cons (car aux-list) + (filter-potentially-dangerous (cdr aux-list)))) + '()))) ;;;; Promises @@ -257,7 +260,7 @@ contains constants derived from the source program. (object-type? (ucode-type delayed) object)) (define-integrable (promise-forced? promise) - (eq? true (system-pair-car promise))) + (eq? #t (system-pair-car promise))) (define-integrable (promise-non-expression? promise) (eqv? 0 (system-pair-car promise))) @@ -282,14 +285,15 @@ contains constants derived from the source program. (system-pair-car promise)) (define (force promise) - (cond ((not (promise? promise)) - (error:wrong-type-argument promise "promise" 'FORCE)) - ((eq? #T (system-pair-car promise)) - (system-pair-cdr promise)) - ((eqv? 0 (system-pair-car promise)) ; compiled promise - (let ((result ((system-pair-cdr promise)))) - (system-pair-set-cdr! promise result) - (system-pair-set-car! promise #T) - result)) - (else ; losing old style - ((ucode-primitive force 1) promise)))) + (if (not (promise? promise)) + (error:wrong-type-argument promise "promise" 'FORCE)) + (case (system-pair-car promise) + ((#T) + (system-pair-cdr promise)) + ((0) ;compiled promise + (let ((result ((system-pair-cdr promise)))) + (system-pair-set-cdr! promise result) + (system-pair-set-car! promise #t) + result)) + (else ;losing old style + ((ucode-primitive force 1) promise)))) \ No newline at end of file diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm index 367a41aaa..d011a5464 100644 --- a/v7/src/runtime/unxprm.scm +++ b/v7/src/runtime/unxprm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: unxprm.scm,v 1.61 2001/05/09 03:17:14 cph Exp $ +$Id: unxprm.scm,v 1.62 2001/12/18 18:40:04 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -21,7 +21,7 @@ USA. |# ;;;; Miscellaneous Unix Primitives -;;; package: () +;;; package: (runtime os-primitives) (declare (usual-integrations)) @@ -97,18 +97,18 @@ USA. (define-structure (file-attributes (type vector) - (constructor false) + (constructor #f) (conc-name file-attributes/)) - (type false read-only true) - (n-links false read-only true) - (uid false read-only true) - (gid false read-only true) - (access-time false read-only true) - (modification-time false read-only true) - (change-time false read-only true) - (length false read-only true) - (mode-string false read-only true) - (inode-number false read-only true)) + (type #f read-only #t) + (n-links #f read-only #t) + (uid #f read-only #t) + (gid #f read-only #t) + (access-time #f read-only #t) + (modification-time #f read-only #t) + (change-time #f read-only #t) + (length #f read-only #t) + (mode-string #f read-only #t) + (inode-number #f read-only #t)) (define (file-length filename) (file-attributes/length (file-attributes-direct filename))) @@ -148,9 +148,9 @@ USA. (define reset-environment-variables!) (let ((environment-variables '())) - ;; Kludge: since getenv returns false for unbound, + ;; Kludge: since getenv returns #f for unbound, ;; that can also be the marker for a deleted variable - (define-integrable *variable-deleted* false) + (define-integrable *variable-deleted* #f) (set! get-environment-variable (lambda (variable) @@ -278,8 +278,8 @@ USA. (define (copy-file from to) (let ((input-filename (->namestring (merge-pathnames from))) (output-filename (->namestring (merge-pathnames to)))) - (let ((input-channel false) - (output-channel false)) + (let ((input-channel #f) + (output-channel #f)) (dynamic-wind (lambda () (set! input-channel (file-open-input-channel input-filename)) @@ -340,7 +340,7 @@ USA. (let ((registry (make-string ((ucode-primitive select-registry-size 0))))) ((ucode-primitive select-registry-clear-all 1) registry) (do ((descriptors descriptors (cdr descriptors))) - ((null? descriptors)) + ((not (pair? descriptors))) ((ucode-primitive select-registry-set 2) registry (car descriptors))) registry)) @@ -402,25 +402,26 @@ USA. (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) (let ((v (let loop ((rv select-registry-result-vectors)) - (cond ((null? rv) - (make-vector ((ucode-primitive select-registry-lub 0)) #f)) - ((car rv) - => (lambda (v) (set-car! rv #f) v)) - (else - (loop (cdr rv))))))) + (if (pair? rv) + (let ((v (car rv))) + (if v + (begin + (set-car! rv #f) + v) + (loop (cdr rv)))) + (make-vector ((ucode-primitive select-registry-lub 0)) #f))))) (set-interrupt-enables! interrupt-mask) v))) (define (deallocate-select-registry-result-vector v) (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) (let loop ((rv select-registry-result-vectors)) - (cond ((null? rv) - (set! select-registry-result-vectors - (cons v select-registry-result-vectors))) - ((car rv) - (loop (cdr rv))) - (else - (set-car! rv v)))) + (if (pair? rv) + (if (car rv) + (loop (cdr rv)) + (set-car! rv v)) + (set! select-registry-result-vectors + (cons v select-registry-result-vectors)))) (set-interrupt-enables! interrupt-mask))) ;;;; Subprocess/Shell Support @@ -445,7 +446,7 @@ USA. (try program)) ((not default-directory) (let loop ((path exec-path)) - (and (not (null? path)) + (and (pair? path) (or (and (car path) (pathname-absolute? (car path)) (try (merge-pathnames program (car path)))) @@ -454,7 +455,7 @@ USA. (let ((default-directory (merge-pathnames default-directory))) (let loop ((path exec-path)) - (and (not (null? path)) + (and (pair? path) (or (try (merge-pathnames program (if (car path) @@ -484,7 +485,7 @@ USA. (let ((index (substring-find-next-char string start end #\:))) (if index (cons (if (= index start) - false + #f (substring string start index)) (loop (+ index 1))) (list (substring string start end)))) diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm index 4f0fb63a1..3f3f8e70f 100644 --- a/v7/src/runtime/vector.scm +++ b/v7/src/runtime/vector.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: vector.scm,v 14.16 2001/08/15 02:56:30 cph Exp $ +$Id: vector.scm,v 14.17 2001/12/18 18:40:07 cph Exp $ -Copyright (c) 1988-2000 Massachusetts Institute of Technology +Copyright (c) 1988-2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -16,18 +16,19 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. |# ;;;; Operations on Vectors -;;; package: () +;;; package: (runtime vector) (declare (usual-integrations)) (define-primitives - vector? vector-length vector-ref vector-set! - list->vector vector subvector->list - subvector-move-right! subvector-move-left! subvector-fill!) + vector? vector-length vector-ref vector-set! + list->vector vector subvector->list + subvector-move-right! subvector-move-left! subvector-fill!) (define-integrable (guarantee-vector object procedure) (if (not (vector? object)) @@ -81,18 +82,18 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (let ((result (make-vector (let loop ((vectors vectors) (length 0)) - (if (null? vectors) - length + (if (pair? vectors) (begin (guarantee-vector (car vectors) 'VECTOR-APPEND) (loop (cdr vectors) - (fix:+ (vector-length (car vectors)) length)))))))) + (fix:+ (vector-length (car vectors)) length))) + length))))) (let loop ((vectors vectors) (index 0)) - (if (null? vectors) - result + (if (pair? vectors) (let ((size (vector-length (car vectors)))) (subvector-move-right! (car vectors) 0 size result index) - (loop (cdr vectors) (fix:+ index size))))))) + (loop (cdr vectors) (fix:+ index size))) + result)))) (define (vector-grow vector length #!optional value) (guarantee-vector vector 'VECTOR-GROW)