├── .gitignore ├── AUTHORS ├── BUILD.md ├── COPYING ├── ChangeLog ├── Makefile.am ├── NEWS ├── README.md ├── configure.ac ├── debian ├── .gitignore ├── changelog ├── control ├── copyright ├── docs ├── menu ├── oaklisp-doc.doc-base.1 ├── oaklisp-doc.doc-base.2 ├── oaklisp-doc.doc-base.3 ├── oaklisp-doc.docs ├── oaklisp-doc.examples ├── oaklisp.install ├── rules ├── source │ ├── format │ ├── include-binaries │ └── local-options └── upstream │ └── metadata ├── doc ├── .gitignore ├── Makefile.am ├── cacm-oaklisp-gc-1996.pdf ├── examples │ ├── bank-example.oak │ ├── change.oak │ ├── test-bank-example.oak │ └── unit-testing.oak ├── lang │ ├── control.tex │ ├── cover.tex │ ├── dynamic.tex │ ├── intro.tex │ ├── io.tex │ ├── lang.tex │ ├── locales.tex │ ├── methods.tex │ ├── misc.tex │ ├── numbers.tex │ ├── numhier.eps │ ├── seqhier.eps │ ├── sequences.tex │ ├── sides.tex │ ├── types.tex │ └── user.tex ├── lasc-oaklisp-1988.pdf ├── lim │ ├── admin.tex │ ├── boot.tex │ ├── bytecode.tex │ ├── compiler.tex │ ├── cover.tex │ ├── dataform.tex │ ├── intro.tex │ ├── language.tex │ ├── lim.tex │ ├── methods.tex │ ├── oaklevel.tex │ └── stack.tex ├── mandefs.tex ├── oaklisp-oopsla-1986.pdf ├── oakman.bib └── summary │ └── OaklispSummary.tex ├── m4 ├── ax_append_flag.m4 ├── ax_c_long_long.m4 ├── ax_cflags_warn_all.m4 └── ax_require_defined.m4 ├── man ├── Makefile.am └── man1 │ └── oaklisp.1.in ├── prebuilt ├── doc │ ├── lang │ │ └── lang.pdf │ ├── lim │ │ └── lim.pdf │ └── summary │ │ └── OaklispSummary.pdf └── src │ ├── emulator │ └── instr-data.c │ └── world │ ├── eb32 │ └── oakworld.bin │ └── el32 │ └── oakworld.bin └── src ├── Makefile.am ├── emulator ├── .gitignore ├── Makefile.am ├── cmdline.c ├── cmdline.h ├── config.h ├── data.c ├── data.h ├── gc.c ├── gc.h ├── instr.c ├── instr.h ├── instruction-table.oak ├── loop.c ├── loop.h ├── oaklisp.c ├── signals.c ├── signals.h ├── stacks-loop.h ├── stacks.c ├── stacks.h ├── threads.c ├── threads.h ├── timers.c ├── timers.h ├── weak.c ├── weak.h ├── worldio.c ├── worldio.h ├── xmalloc.c └── xmalloc.h ├── misc ├── README ├── testing-tests.oak ├── uniq.oak └── unit-testing.oak └── world ├── .gitignore ├── Makefile-vars ├── Makefile.am ├── alarm.oak ├── anonymous.oak ├── apropos.oak ├── assembler.oak ├── backquote.oak ├── bignum.oak ├── bignum2.oak ├── booted.oak ├── bounders.oak ├── bp-alist.oak ├── catch.oak ├── cmdline-getopt.oak ├── cmdline-options.oak ├── cmdline.oak ├── code-vector.oak ├── coerce.oak ├── cold-boot-end.oak ├── cold-booting.oak ├── cold.oak ├── compile-bench.oak ├── compiler-exports.oak ├── complex.oak ├── conses.oak ├── consume.oak ├── continuation.oak ├── crunch.oak ├── da.oak ├── define.oak ├── del.oak ├── describe.oak ├── destructure.oak ├── do.oak ├── dump-stack.oak ├── em.oak ├── eqv.oak ├── error.oak ├── error2.oak ├── error3.oak ├── eval.oak ├── exit.oak ├── expand.oak ├── export.oak ├── fasl.oak ├── fastmap.oak ├── file-compiler.oak ├── file-errors.oak ├── file-io.oak ├── files.oak ├── fluid.oak ├── format.oak ├── freeze.oak ├── gc.oak ├── has-method.oak ├── hash-reader.oak ├── hash-table.oak ├── icky-macros.oak ├── interpreter.oak ├── kernel.oak ├── kernel0.oak ├── kernel0types.oak ├── kernel1-freeze.oak ├── kernel1-funs.oak ├── kernel1-inittypes.oak ├── kernel1-install.oak ├── kernel1-make.oak ├── kernel1-maketype.oak ├── kernel1-segments.oak ├── lazy-cons.oak ├── list.oak ├── load-file.oak ├── load-oaf.oak ├── locales.oak ├── logops.oak ├── mac-code.oak ├── mac-comp-stuff.oak ├── mac-compiler-nodes.oak ├── mac-compiler1.oak ├── mac-compiler2.oak ├── mac-compiler3.oak ├── macros0.oak ├── macros1.oak ├── macros2.oak ├── make-locales.oak ├── make-makefile.oak ├── mapping.oak ├── math.oak ├── mix-types.oak ├── multi-em.oak ├── multi-off.oak ├── multiproc-tests.oak ├── multiproc.oak ├── nargs.oak ├── numbers.oak ├── obsolese.oak ├── op-error.oak ├── operations.oak ├── ops.oak ├── patch-locales.oak ├── patch-symbols.oak ├── patch0symbols.oak ├── peephole.oak ├── pl.oak ├── predicates.oak ├── print-integer.oak ├── print-list.oak ├── print-noise.oak ├── print.oak ├── prolog-examples.oak ├── prolog.oak ├── promise.oak ├── random.oak ├── rational.oak ├── read-char.oak ├── read-token.oak ├── reader-errors.oak ├── reader-macros.oak ├── reader.oak ├── repl.oak ├── rounding.oak ├── scheme-macros.oak ├── scheme.oak ├── sequences.oak ├── signal.oak ├── sort.oak ├── st.oak ├── streams.oak ├── string-stream.oak ├── strings.oak ├── subprimitive.oak ├── subtypes.oak ├── super.oak ├── symbols.oak ├── system-version.oak.in ├── tag-trap.oak ├── tak.oak ├── time.oak ├── tool.oak ├── top-level.oak ├── trace.oak ├── truth.oak ├── undefined.oak ├── unwind-protect.oak ├── vector-type.oak ├── vl-mixin.oak ├── warm.oak └── weak.oak /.gitignore: -------------------------------------------------------------------------------- 1 | .deps/ 2 | .dirstamp 3 | /INSTALL 4 | /aclocal.m4 5 | /autom4te.cache/ 6 | /compile 7 | /config.guess 8 | /config.h 9 | /config.h.in 10 | /config.log 11 | /config.status 12 | /config.sub 13 | /configure 14 | /depcomp 15 | /install-sh 16 | /man/man1/oaklisp.1 17 | /missing 18 | /src/world/system-version.oak 19 | /stamp-h1 20 | Makefile 21 | Makefile.in 22 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | This is a credits-file of people that have contributed to the 2 | Oaklisp project. It is formatted to allow easy grepping and 3 | beautification by scripts. The fields are: name (N), email 4 | (E), web-address (W), PGP key ID and fingerprint (P), 5 | description (D), and snail-mail address (S). 6 | 7 | ---------- 8 | 9 | N: Kevin J. Lang 10 | E: langk@yahoo-inc.com 11 | D: much of language design. much of system design. 12 | D: much of lang & lim manuals. 13 | D: bytecode compiler. list manipulation. much of emulator. world i/o. 14 | D: much of runtime system. bignum division. much of bignums. 15 | S: Yahoo! Research 16 | 17 | N: Barak A. Pearlmutter 18 | E: barak+oaklisp@pearlmutter.net 19 | W: http://barak.pearlmutter.net/ 20 | P: pub rsa4096/125B57475E190D18 2010-10-13 [SC] 21 | P: Key fingerprint = 64F4 29E3 6EA1 1CC2 D966 546F 125B 5747 5E19 0D18 22 | D: much of language design. much of system design. 23 | D: much of lang & lim manuals. 24 | D: most of bytecode emulator. call/cc. weak pointers. gc. strings. 25 | D: much of runtime system. I/O. much of bignums. rationals. vectors. 26 | D: interpreter. hash tables. symbols. locales. macros. delays. 27 | S: Dept. of Computer Science 28 | S: Maynooth University 29 | S: Co. Kildare 30 | S: Ireland 31 | 32 | N: Alexander Stuebinger 33 | E: stuebi@acm.org 34 | W: http://www.uni-mainz.de/~stuebi 35 | D: emulator mods 93 -> 99: optimizations, ANSI-ification, etc. 36 | S: Burgunderstrasse 3 37 | S: 76829 Landau 38 | S: Germany 39 | 40 | N: Joerg-Cyril Hoehle 41 | E: hoehle@tzd.telekom.de 42 | D: helped alex spec out his emulator mods 43 | D: perceptive bug-sniffer and system tester: found make-lambda %full-gc bug 44 | D: ported SLIB and GAMBIT-benchmarks to Oaklisp 45 | D: scheme-locale mods 46 | 47 | N: Blake McBride 48 | E: blake@mcbride.name 49 | W: http://blake.mcbride.name 50 | D: Wrote the OaklispSummary document. 51 | D: Build system updates and documentation. 52 | D: Misc bug reports and bug fixes 53 | D: Various tweaks and enhancements. 54 | D: Motivation. 55 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 2015-03-13 Barak A. Pearlmutter 2 | 3 | * oaklisp.1 fill in paths at make time 4 | * configure.ac properly seek 32-bit memory model options on 64-bit hosts 5 | * documentation add more build documentation 6 | * world include prebuilt for big-endian, tweak location and search code 7 | * autotools minor tweaks to build and use standard constructs throughout 8 | * system-version.oak to pass version from configure.ac 9 | 10 | 2015-03-03 Barak A. Pearlmutter 11 | 12 | * autotools build system 13 | * rubber to build LaTeX documentation 14 | * prebuilt world on separate git branch 15 | * ChangeLog file created for automake happiness 16 | * AUTHORS file renamed from src/CREDITS for automake happiness 17 | -------------------------------------------------------------------------------- /Makefile.am: -------------------------------------------------------------------------------- 1 | # This file is part of Oaklisp. 2 | # 3 | # This program is free software; you can redistribute it and/or modify 4 | # it under the terms of the GNU General Public License as published by 5 | # the Free Software Foundation; either version 2 of the License, or 6 | # (at your option) any later version. 7 | # 8 | # This program is distributed in the hope that it will be useful, 9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | # GNU General Public License for more details. 12 | # 13 | # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | # or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | # Boston, MA 02111-1307, USA 16 | 17 | SUBDIRS = src man 18 | 19 | if DOCS 20 | SUBDIRS += doc 21 | endif 22 | 23 | doc_DATA = README.md AUTHORS COPYING BUILD.md ChangeLog NEWS 24 | -------------------------------------------------------------------------------- /NEWS: -------------------------------------------------------------------------------- 1 | Build system switched to autotools. 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Oaklisp 2 | ======= 3 | 4 | Oaklisp is an object-oriented dialect of lisp sharing the standard 5 | lisp syntax, including common lisp style macros, first class types, 6 | multiple inheritance, and multiple namespaces (packages). Oaklisp is 7 | also a Lisp-1 dialect meaning functions and variables share the same 8 | namespace (like Scheme). 9 | 10 | This is a portable implementation of a lisp interpreter / compiler for 11 | the Oaklisp dialect of lisp. 12 | 13 | Project homepage(s) 14 | 15 | * https://github.com/barak/oaklisp (homepage, development) 16 | * http://barak.pearlmutter.net/oaklisp/ (ancient history) 17 | 18 | The compiler compiles Oaklisp source code into byte-code for the 19 | included Oaklisp emulator / virtual machine. The implementation 20 | is described in the included documentation, and also in 21 | 22 | * Kevin J. Lang and Barak A. Pearlmutter. Oaklisp: an object-oriented 23 | Scheme with first class types. In OOPSLA-86, pages 30–7. doi: 24 | 10.1145/960112.28701. Special issue of ACM SIGPLAN Notices 21(11). 25 | URL http://barak.pearlmutter.net/papers/oaklisp-oopsla-1986.pdf 26 | 27 | * Kevin J. Lang and Barak A. Pearlmutter. Oaklisp: an object-oriented 28 | dialect of Scheme. Lisp and Symbolic Computation, 1(1):39–51, May 29 | 1988. 30 | URL http://barak.pearlmutter.net/papers/lasc-oaklisp-1988.pdf 31 | 32 | * Barak A. Pearlmutter. Garbage collection with pointers to individual 33 | cells. Communications of the ACM, 39(12):202–6, December 1996. 34 | doi: 10.1145/272682.272712. 35 | URL http://barak.pearlmutter.net/papers/cacm-oaklisp-gc-1996.pdf 36 | 37 | * Barak A. Pearlmutter and Kevin J. Lang. The implementation of 38 | Oaklisp. In Peter Lee, editor, Topics in Advanced Language 39 | Implementation, pages 189–215. MIT Press, 1991. 40 | URL http://barak.pearlmutter.net/papers/Oaklisp-TALI-Chapter-1991.djvu 41 | http://barak.pearlmutter.net/papers/Oaklisp-TALI-Chapter-1991.pdf 42 | 43 | See BUILD.md for instructions on how to build the system. 44 | -------------------------------------------------------------------------------- /debian/.gitignore: -------------------------------------------------------------------------------- 1 | /*.debhelper 2 | /*.log 3 | /*.substvars 4 | /autoreconf.after 5 | /autoreconf.before 6 | /debhelper-build-stamp 7 | /files 8 | /oaklisp-doc/ 9 | /oaklisp/ 10 | /tmp/ 11 | -------------------------------------------------------------------------------- /debian/control: -------------------------------------------------------------------------------- 1 | Source: oaklisp 2 | Section: lisp 3 | Priority: optional 4 | Maintainer: Barak A. Pearlmutter 5 | Standards-Version: 4.6.0 6 | Build-Depends: 7 | debhelper-compat (= 13), 8 | autoconf-archive, 9 | gcc-multilib [any-alpha any-amd64 any-arm64 any-ia64 any-mips64 any-mips64el any-ppc64 any-ppc64el any-riscv64 any-s390x any-sparc64] 10 | Build-Depends-Indep: 11 | texlive-latex-base , texlive-latex-extra , texlive-fonts-recommended , 12 | latexmk , texlive-font-utils , ghostscript 13 | Homepage: https://github.com/barak/oaklisp/ 14 | Vcs-Git: https://salsa.debian.org/debian/oaklisp.git 15 | Vcs-Browser: https://salsa.debian.org/debian/oaklisp 16 | 17 | Package: oaklisp 18 | Architecture: any 19 | Multi-Arch: foreign 20 | Depends: ${shlibs:Depends}, ${misc:Depends} 21 | Description: Object-oriented dialect of Scheme 22 | Oaklisp is a dialect of Scheme that combines lexical scoping with 23 | first-class types. It uses a byte-coded implementation, but is 24 | reasonably fast anyway. Complete with bignums, formatted output, 25 | transparent delays, RnRS compatibility package; all the luxuries 26 | except floating point and foreign function calls. 27 | 28 | Package: oaklisp-doc 29 | Section: doc 30 | Architecture: all 31 | Depends: ${misc:Depends} 32 | Build-Profiles: 33 | Suggests: oaklisp, postscript-viewer 34 | Description: Object-oriented dialect of Scheme, documentation 35 | Documentation for the Oaklisp object-oriented dialect of Scheme. 36 | Oaklisp is a dialect of Scheme that combines lexical scoping with 37 | first-class types. It uses a byte-coded implementation, but is 38 | reasonably fast anyway. Complete with bignums, formatted output, 39 | transparent delays, RnRS compatibility package; all the luxuries 40 | except floating point and foreign function calls. 41 | -------------------------------------------------------------------------------- /debian/copyright: -------------------------------------------------------------------------------- 1 | Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ 2 | Upstream-Name: oaklisp 3 | Source: https://github.com/barak/oaklisp 4 | 5 | Files: * 6 | Copyright: 1987-2015 Barak A. Pearlmutter and Kevin J. Lang 7 | License: GPL-2.0+ 8 | 9 | Files: src/emulator/* 10 | Copyright: 1987-2015 Barak A. Pearlmutter and Kevin J. Lang 11 | 1998-1999 Alex Stuebinger 12 | License: GPL-2.0+ 13 | 14 | License: GPL-2.0+ 15 | Files: doc/summary/* 16 | Copyright: 2014 Blake McBride 17 | 18 | Files: debian/* 19 | Copyright: 2000 Tony Mancill 20 | 2001-2015 Barak A. Pearlmutter 21 | License: GPL-2.0+ 22 | 23 | License: GPL-2.0+ 24 | This package is free software; you can redistribute it and/or modify 25 | it under the terms of the GNU General Public License as published by 26 | the Free Software Foundation; either version 2 of the License, or 27 | (at your option) any later version. 28 | . 29 | This package is distributed in the hope that it will be useful, 30 | but WITHOUT ANY WARRANTY; without even the implied warranty of 31 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 32 | GNU General Public License for more details. 33 | . 34 | You should have received a copy of the GNU General Public License 35 | along with this program. If not, see 36 | . 37 | On Debian systems, the complete text of the GNU General 38 | Public License version 2 can be found in "/usr/share/common-licenses/GPL-2". 39 | -------------------------------------------------------------------------------- /debian/docs: -------------------------------------------------------------------------------- 1 | /usr/share/doc/oaklisp/README.md 2 | /usr/share/doc/oaklisp/AUTHORS 3 | /usr/share/doc/oaklisp/BUILD.md 4 | /usr/share/doc/oaklisp/NEWS 5 | -------------------------------------------------------------------------------- /debian/menu: -------------------------------------------------------------------------------- 1 | ?package(oaklisp): needs="text" \ 2 | section="Applications/Programming" \ 3 | title="Oaklisp" \ 4 | command="/usr/bin/oaklisp" 5 | -------------------------------------------------------------------------------- /debian/oaklisp-doc.doc-base.1: -------------------------------------------------------------------------------- 1 | Document: oaklisp-lang 2 | Title: Oaklisp Language Manual 3 | Author: Barak A. Pearlmutter and Kevin J. Lang 4 | Abstract: Description of the Oaklisp language for programmers. 5 | Section: Programming/Scheme 6 | 7 | Format: PDF 8 | Files: /usr/share/doc/oaklisp/lang.pdf.gz 9 | -------------------------------------------------------------------------------- /debian/oaklisp-doc.doc-base.2: -------------------------------------------------------------------------------- 1 | Document: oaklisp-lim 2 | Title: Oaklisp Implementation Manual 3 | Author: Barak A. Pearlmutter and Kevin J. Lang 4 | Abstract: Description of the implementation internals of the Oaklisp 5 | language, for those who wish to modify or extend the implementation. 6 | Section: Programming/Scheme 7 | 8 | Format: PDF 9 | Files: /usr/share/doc/oaklisp/lim.pdf.gz 10 | -------------------------------------------------------------------------------- /debian/oaklisp-doc.doc-base.3: -------------------------------------------------------------------------------- 1 | Document: oaklisp-summary 2 | Title: Oaklisp Summary 3 | Author: Blake McBride 4 | Abstract: Oaklisp Summary 5 | Concise user-level summary of the Oaklisp language for the working 6 | programmer. 7 | Section: Programming/Scheme 8 | 9 | Format: PDF 10 | Files: /usr/share/doc/oaklisp/OaklispSummary.pdf.gz 11 | -------------------------------------------------------------------------------- /debian/oaklisp-doc.docs: -------------------------------------------------------------------------------- 1 | /usr/share/doc/oaklisp/*.pdf 2 | -------------------------------------------------------------------------------- /debian/oaklisp-doc.examples: -------------------------------------------------------------------------------- 1 | doc/examples/*.oak 2 | -------------------------------------------------------------------------------- /debian/oaklisp.install: -------------------------------------------------------------------------------- 1 | /usr/bin/oaklisp 2 | /usr/lib/*/oaklisp/oakworld.bin 3 | /usr/share/man/*/* 4 | -------------------------------------------------------------------------------- /debian/rules: -------------------------------------------------------------------------------- 1 | #!/usr/bin/make -f 2 | 3 | # Uncomment this to turn on verbose mode. 4 | # export DH_VERBOSE=1 5 | 6 | export DEB_BUILD_MAINT_OPTIONS = hardening=+all 7 | DOPACKAGES = $(shell dh_listpackages) 8 | 9 | %: 10 | dh $@ 11 | 12 | ifeq (,$(filter oaklisp-doc,$(DOPACKAGES))) 13 | override_dh_auto_configure: 14 | dh_auto_configure -- --disable-docs 15 | endif 16 | 17 | override_dh_auto_install: 18 | dh_auto_install 19 | -rm --verbose debian/tmp/usr/share/doc/oaklisp/ChangeLog 20 | -rm --verbose debian/tmp/usr/share/doc/oaklisp/COPYING 21 | -------------------------------------------------------------------------------- /debian/source/format: -------------------------------------------------------------------------------- 1 | 3.0 (quilt) 2 | -------------------------------------------------------------------------------- /debian/source/include-binaries: -------------------------------------------------------------------------------- 1 | prebuilt/doc/lang/lang.pdf 2 | prebuilt/doc/lim/lim.pdf 3 | prebuilt/doc/summary/OaklispSummary.pdf 4 | prebuilt/src/world/eb32/oakworld.bin 5 | prebuilt/src/world/el32/oakworld.bin 6 | -------------------------------------------------------------------------------- /debian/source/local-options: -------------------------------------------------------------------------------- 1 | single-debian-patch 2 | -------------------------------------------------------------------------------- /debian/upstream/metadata: -------------------------------------------------------------------------------- 1 | --- 2 | Bug-Database: https://github.com/barak/oaklisp/issues 3 | Bug-Submit: https://github.com/barak/oaklisp/issues/new 4 | -------------------------------------------------------------------------------- /doc/.gitignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | *.bbl 3 | *.blg 4 | *.fdb_latexmk 5 | *.fls 6 | *.idx 7 | *.ilg 8 | *.ind 9 | *.log 10 | *.pdf 11 | *.toc 12 | -------------------------------------------------------------------------------- /doc/Makefile.am: -------------------------------------------------------------------------------- 1 | # This file is part of Oaklisp. 2 | # 3 | # This program is free software; you can redistribute it and/or modify 4 | # it under the terms of the GNU General Public License as published by 5 | # the Free Software Foundation; either version 2 of the License, or 6 | # (at your option) any later version. 7 | # 8 | # This program is distributed in the hope that it will be useful, 9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | # GNU General Public License for more details. 12 | # 13 | # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | # or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | # Boston, MA 02111-1307, USA 16 | 17 | LATEX_SRCS = lang/lang.tex lim/lim.tex summary/OaklispSummary.tex 18 | LATEX_PDFS = lang/lang.pdf lim/lim.pdf summary/OaklispSummary.pdf 19 | 20 | pdf_DATA = $(LATEX_PDFS) 21 | 22 | EXTRA_DIST = $(LATEX_SRCS) 23 | 24 | .tex.pdf: 25 | (cd $(dir $<) && $(LATEXMK) -pdf $(notdir $<)) \ 26 | || cp ../prebuilt/doc/$@ $@ 27 | 28 | EXTRA_DIST += examples/bank-example.oak examples/change.oak \ 29 | examples/test-bank-example.oak examples/unit-testing.oak \ 30 | lang/control.tex lang/cover.tex lang/dynamic.tex lang/intro.tex \ 31 | lang/io.tex lang/locales.tex lang/methods.tex lang/misc.tex \ 32 | lang/numbers.tex lang/numhier.eps lang/seqhier.eps \ 33 | lang/sequences.tex lang/sides.tex lang/types.tex lang/user.tex \ 34 | lim/admin.tex lim/boot.tex lim/bytecode.tex lim/compiler.tex \ 35 | lim/cover.tex lim/dataform.tex lim/intro.tex lim/language.tex \ 36 | lim/methods.tex lim/oaklevel.tex lim/stack.tex mandefs.tex \ 37 | oakman.bib 38 | 39 | CLEANFILES = $(LATEX_PDFS) 40 | 41 | CLEANFILES += lang/control.aux lang/cover.aux lang/dynamic.aux \ 42 | lang/intro.aux lang/io.aux lang/lang.aux lang/lang.bbl lang/lang.blg \ 43 | lang/lang.fdb_latexmk lang/lang.fls lang/lang.idx lang/lang.ilg \ 44 | lang/lang.ind lang/lang.log lang/lang.toc lang/locales.aux \ 45 | lang/methods.aux lang/misc.aux lang/numbers.aux \ 46 | lang/numhier-eps-converted-to.pdf lang/seqhier-eps-converted-to.pdf \ 47 | lang/sequences.aux lang/sides.aux lang/types.aux lang/user.aux 48 | 49 | CLEANFILES += lim/admin.aux lim/boot.aux lim/bytecode.aux \ 50 | lim/compiler.aux lim/cover.aux lim/dataform.aux lim/intro.aux \ 51 | lim/language.aux lim/lim.aux lim/lim.bbl lim/lim.blg \ 52 | lim/lim.fdb_latexmk lim/lim.fls lim/lim.idx lim/lim.ilg lim/lim.ind \ 53 | lim/lim.log lim/lim.toc lim/methods.aux lim/oaklevel.aux \ 54 | lim/stack.aux 55 | 56 | CLEANFILES += summary/OaklispSummary.aux \ 57 | summary/OaklispSummary.fdb_latexmk summary/OaklispSummary.fls \ 58 | summary/OaklispSummary.log 59 | -------------------------------------------------------------------------------- /doc/examples/change.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Number of ways of giving change, Barak A. Pearlmutter, Fall 1989. 19 | ;;; This technique is covered in Concrete Mathamatics by Graham, Knuth 20 | ;;; and Patashnik, page 331. 21 | 22 | ;;; Helper functions: 23 | 24 | ;;; This computes the number of ways to choose m objects from a pool 25 | ;;; of n. The arguments are in the usual mathematical order. 26 | 27 | (define (choose n m) 28 | (let aux ((n n)(m1 m)(total 1)) 29 | (if (= m1 0) 30 | (let aux ((m m)(total2 1)) 31 | (if (= m 0) 32 | (/ total total2) 33 | (aux (- m 1) (* m total2)))) 34 | (aux (- n 1) (- m1 1) (* n total))))) 35 | 36 | ;;; These are the coefficients of the polynomial a(z) = (1-z^{10})^5 / 37 | ;;; (1-z)^2(1-z^2)(1-z^5)(1-z^{10}). The end should be zero padded to 38 | ;;; infinity, but the arguments given are always between 0 and 39 39 | ;;; inclusive. 40 | 41 | (define (a i) 42 | (nth '(01 02 04 06 09 13 18 24 31 39 45 52 57 63 67 69 43 | 69 67 63 57 52 45 39 31 24 18 13 09 06 04 02 01 44 | 0 0 0 0 0 0 0 0) 45 | i)) 46 | 47 | ;;; This returns the number of ways to make change on c cents using 48 | ;;; coins of denomination 1,5,10,25,50. The math behind this is too 49 | ;;; hairy for a comment, as it requires lots of superscripts and sums 50 | ;;; and stuff. In effect, we end up casing on (c mod 50) with each 51 | ;;; case determining the coefficients of a fourth order polynomial of 52 | ;;; floor(c/50). 53 | 54 | (define (change c) 55 | (let* ((c5 (quotient c 5)) 56 | (q (quotient c5 10)) 57 | (r (modulo c5 10))) 58 | (+ (* (a r) (choose (+ q 4) 4)) 59 | (* (a (+ r 10)) (choose (+ q 3) 4)) 60 | (* (a (+ r 20)) (choose (+ q 2) 4)) 61 | (* (a (+ r 30)) (choose (+ q 1) 4))))) 62 | 63 | 64 | ;;; Test case, the number of ways of giving change for $1,000,000.00 65 | ;;; (change 100000000) = 66666793333412666685000001. 66 | 67 | ;;; For $1,000,000,000,000,000,000.00, 68 | ;;; (change 100000000000000000000) 69 | ;;; 66666666666666666793333333333333333412666666666666666685000000000000000001 70 | 71 | ;;; eof 72 | -------------------------------------------------------------------------------- /doc/lang/cover.tex: -------------------------------------------------------------------------------- 1 | % This file is part of Oaklisp. 2 | % 3 | % This program is free software; you can redistribute it and/or modify 4 | % it under the terms of the GNU General Public License as published by 5 | % the Free Software Foundation; either version 2 of the License, or 6 | % (at your option) any later version. 7 | % 8 | % This program is distributed in the hope that it will be useful, 9 | % but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | % GNU General Public License for more details. 12 | % 13 | % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | % or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | % Boston, MA 02111-1307, USA 16 | 17 | 18 | \begin{titlepage} 19 | 20 | \begin{center} 21 | 22 | \vspace*{1in} 23 | 24 | \Huge 25 | The \\ 26 | Oaklisp Language Manual \\ 27 | 28 | \vspace{.5in} 29 | 30 | \large 31 | \today \\ 32 | 33 | \vspace{.25in} 34 | 35 | % \Huge DRAFT \\ 36 | 37 | \vspace{.5in} 38 | 39 | \Large 40 | Barak A. Pearlmutter \\ 41 | \large 42 | Dept. of Computer Science\\ 43 | Maynooth University\\ 44 | Co.\ Kildare\\ 45 | Ireland\\ 46 | \url{barak+oaklisp@pearlmutter.net} 47 | 48 | \vspace{.5in} 49 | 50 | \Large 51 | Kevin J. Lang \\ 52 | \large 53 | Yahoo!\ Research \\ 54 | \url{langk@yahoo-inc.com} 55 | 56 | \vfill 57 | 58 | % \vspace{0.25in} 59 | % The information in this document is subject to change at any time. 60 | 61 | \end{center} 62 | 63 | \end{titlepage} 64 | 65 | 66 | \thispagestyle{empty} 67 | 68 | \vspace*{6in} 69 | 70 | \normalsize 71 | \noindent Copyright \copyright 1985, 1986, 1987, 1988, 1989, 1991. 72 | by Barak A. Pearlmutter and Kevin J. Lang. 73 | 74 | \newpage 75 | 76 | \pagenumbering{roman} 77 | 78 | 79 | -------------------------------------------------------------------------------- /doc/lang/lang.tex: -------------------------------------------------------------------------------- 1 | % This file is part of Oaklisp. 2 | % 3 | % This program is free software; you can redistribute it and/or modify 4 | % it under the terms of the GNU General Public License as published by 5 | % the Free Software Foundation; either version 2 of the License, or 6 | % (at your option) any later version. 7 | % 8 | % This program is distributed in the hope that it will be useful, 9 | % but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | % GNU General Public License for more details. 12 | % 13 | % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | % or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | % Boston, MA 02111-1307, USA 16 | 17 | \documentclass[12pt]{report} % Blake McBride suggests [...,twoside]{book} 18 | \usepackage{times} 19 | \usepackage{fullpage} 20 | \usepackage{graphicx} 21 | \usepackage{makeidx} 22 | \usepackage[numbers]{natbib} 23 | \usepackage[hyphens]{url} 24 | \urlstyle{same} 25 | 26 | \makeindex 27 | 28 | \begin{document} 29 | 30 | \input{../mandefs} 31 | 32 | \include{cover} 33 | \tableofcontents 34 | \newpage 35 | \pagenumbering{arabic} 36 | \include{intro} 37 | \include{types} 38 | \include{methods} 39 | \include{sides} 40 | \include{locales} 41 | \include{dynamic} 42 | \include{control} 43 | \include{sequences} 44 | \include{numbers} 45 | \include{io} 46 | \include{misc} 47 | \include{user} 48 | 49 | \nocite{OAKLANG88} 50 | \nocite{CLOOPS} 51 | \nocite{FLAVORS2} 52 | \nocite{MVC} 53 | \nocite{R3RS} 54 | \nocite{SCHEME-DECLARATIVE} 55 | \nocite{SCHEME-PAP} 56 | \nocite{SNYDER86} 57 | \nocite{T} 58 | \nocite{T-MAN} 59 | \nocite{OAK-PAP} 60 | \nocite{3LISP} 61 | \nocite{FLAVORS1} 62 | \nocite{CLtL} 63 | \nocite{MULTILISP85} 64 | \nocite{ACTORS78} 65 | \nocite{CITY-TRASH} 66 | \nocite{PEARLMUTTER-LANG90A} 67 | \nocite{PEARLMUTTER99} 68 | 69 | \bibliography{../oakman} 70 | 71 | \printindex 72 | 73 | \end{document} 74 | -------------------------------------------------------------------------------- /doc/lang/numbers.tex: -------------------------------------------------------------------------------- 1 | % This file is part of Oaklisp. 2 | % 3 | % This program is free software; you can redistribute it and/or modify 4 | % it under the terms of the GNU General Public License as published by 5 | % the Free Software Foundation; either version 2 of the License, or 6 | % (at your option) any later version. 7 | % 8 | % This program is distributed in the hope that it will be useful, 9 | % but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | % GNU General Public License for more details. 12 | % 13 | % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | % or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | % Boston, MA 02111-1307, USA 16 | 17 | 18 | \chapter{Numbers} \label{numbers} 19 | 20 | \index{\texttt{number}} \index{\texttt{real}} \index{\texttt{complex}} 21 | \index{\texttt{rational}} \index{\texttt{float}} \index{\texttt{integer}} 22 | \index{\texttt{fraction}} \index{\texttt{fixnum}} \index{\texttt{bignum}} 23 | 24 | \begin{figure}[h] 25 | \centering\includegraphics{numhier} 26 | \caption{The numeric type hierarchy. Abstract types are in plain face 27 | and instantiable ones in bold. Floating point numbers are not 28 | implemented.} \label{fig:numhier} 29 | \end{figure} 30 | 31 | \section{Arithmetic} 32 | 33 | \op{+}{\dt numbers} 34 | \op{1+}{n} 35 | \op{-}{n1 n2 \dt numbers} 36 | \op{-}{n} 37 | \op{*}{\dt numbers} 38 | \op{/}{n1 n2} 39 | \op{quotient}{n1 n2} 40 | \op{modulo}{n1 n2} 41 | \op{abs}{n1} 42 | \op{max}{n1 n2} 43 | \op{min}{n1 n2} 44 | \op{expt}{n1 n2} 45 | 46 | 47 | \section{Comparison} 48 | 49 | \op{=}{n1 n2} 50 | \op{{\protect\bang}=}{n1 n2} 51 | \op{<}{n1 n2} 52 | \op{>}{n1 n2} 53 | \op{<=}{n1 n2} 54 | \op{>=}{n1 n2} 55 | 56 | 57 | \section{Predicates} 58 | 59 | \pr{zero?}{n} 60 | \pr{negative?}{n} 61 | \pr{positive?}{n} 62 | \pr{even?}{n} 63 | \pr{odd?}{n} 64 | \pr{factor?}{n1 n2} 65 | 66 | 67 | \section{Rounding} 68 | 69 | These operations should work on any subtype of \df{real}. 70 | 71 | \op{floor}{x} 72 | \doc{Returns the largest integer less than or equal to \emph{x}.} 73 | 74 | \op{ceiling}{x} 75 | \doc{Returns the smallest integer greater than or equal to \emph{x}.} 76 | 77 | \op{truncate}{x} 78 | \doc{Could be defined \texttt{(if (negative?\ x) (ceiling x) (floor x))}.} 79 | 80 | \op{round}{x} 81 | \doc{Returns nearest integer to \emph{x}. Ties are broken by rounding 82 | to an even number.} 83 | 84 | \section{Bitwise Logical Operations} 85 | 86 | These operations are only defined for integers. 87 | 88 | \op{ash-left}{i amount} 89 | \op{ash-right}{i amount} 90 | \op{rot-left}{i amount} 91 | \op{rot-right}{i amount} 92 | \op{bit-not}{i} 93 | \op{bit-and}{i1 i2} 94 | \op{bit-or}{i1 i2} 95 | \op{bit-nor}{i1 i2} 96 | \op{bit-xor}{i1 i2} 97 | \op{bit-nand}{i1 i2} 98 | \op{bit-andca}{i1 i2} 99 | \op{bit-equiv}{i1 i2} 100 | 101 | 102 | \section{Accessing Components} 103 | 104 | \op{numerator}{rational} 105 | \op{denominator}{rational} 106 | 107 | \op{real-part}{number} 108 | \op{imag-part}{number} 109 | -------------------------------------------------------------------------------- /doc/lasc-oaklisp-1988.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/barak/oaklisp/0fb7ff88289dc10985749ada33e74b5e7db2ed20/doc/lasc-oaklisp-1988.pdf -------------------------------------------------------------------------------- /doc/lim/admin.tex: -------------------------------------------------------------------------------- 1 | % This file is part of Oaklisp. 2 | % 3 | % This program is free software; you can redistribute it and/or modify 4 | % it under the terms of the GNU General Public License as published by 5 | % the Free Software Foundation; either version 2 of the License, or 6 | % (at your option) any later version. 7 | % 8 | % This program is distributed in the hope that it will be useful, 9 | % but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | % GNU General Public License for more details. 12 | % 13 | % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | % or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | % Boston, MA 02111-1307, USA 16 | 17 | 18 | \chapter{Administrative Details} 19 | 20 | \section{Getting a Copy} 21 | 22 | See \url{https://github.com/barak/oaklisp/}. 23 | 24 | \section{Bugs} 25 | 26 | The following are known serious problems and inadequacies of the 27 | current implementation. People are invited to work on remedying them. 28 | None of these are fundamental; they're simply due to lack of either 29 | effort or motivation. 30 | 31 | \begin{itemize} 32 | \item Floating point numbers are not supported. Rationals can be 33 | used to make up for this lack. 34 | 35 | \item In contrast to the error handling system, which is Industrial 36 | Strength, the debugger barely exists. 37 | 38 | \item There is no foreign function interface for loading and calling 39 | C routines from a running Oaklisp. 40 | 41 | %% Removed because this has been tightened up so much that only someone 42 | %% familiar with the internals would be able to cobble up something that 43 | %% would cause a core dump when invoked, and that would take some work. 44 | % 45 | % \item Calling some non-operations dumps core rather than invoking the 46 | % debugger. 47 | \end{itemize} 48 | 49 | Bug reports, enhancements, and the like should be posted using the 50 | facilities on \url{https://github.com/barak/oaklisp/}; queries can 51 | also be sent to \texttt{barak+oaklisp@pearlmutter.net}. 52 | 53 | We appreciate enhancements (especially in the form of patch files), 54 | bug fixes, and bug reports. We are particularly grateful for porting 55 | problem fixes. In a bug report, please include the precise version of 56 | Oaklisp, which is indicated by the date at the end of the tar file. 57 | And please try to make sure that it's really a bug and not a feature, 58 | and pretty please, if at all possible, find a \emph{very short} program 59 | that manifests your bug. In any case please be aware that we are 60 | under no obligation to respond to bug reports in any way whatsoever. 61 | 62 | \section{Copyright and Lack of Warranty} 63 | 64 | The Oaklisp copyright belongs to its authors. It is authorized for 65 | distribution under the GNU General Public License, version 2, copies 66 | of which are readily obtainable from the Free Software Foundation. 67 | There is no warranty; use at your own risk. For more precise 68 | information, see the COPYING file in the Oaklisp source distribution. 69 | -------------------------------------------------------------------------------- /doc/lim/compiler.tex: -------------------------------------------------------------------------------- 1 | % This file is part of Oaklisp. 2 | % 3 | % This program is free software; you can redistribute it and/or modify 4 | % it under the terms of the GNU General Public License as published by 5 | % the Free Software Foundation; either version 2 of the License, or 6 | % (at your option) any later version. 7 | % 8 | % This program is distributed in the hope that it will be useful, 9 | % but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | % GNU General Public License for more details. 12 | % 13 | % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | % or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | % Boston, MA 02111-1307, USA 16 | 17 | 18 | \chapter{The Compiler} 19 | 20 | \subsection{File Types} 21 | 22 | There are a number of different kinds of object files, distinguished 23 | by extension. 24 | 25 | \begin{center} 26 | \begin{tabular}{l|l} 27 | \emph{extension} & \multicolumn{1}{c}\emph{file type} \\\hline 28 | \tt .oak & Oaklisp source file \\ 29 | \tt .omac & Macroexpanded Oaklisp source file \\ 30 | \tt .ou & Assembly file, not peephole optimized \\ 31 | \tt .oc & Assembly file, peephole optimized \\ 32 | \tt .oa & Assembled object file 33 | \end{tabular} 34 | \end{center} 35 | 36 | \gv{compiler-from-extension} 37 | \doc{The extension of the input files the compiler will read. 38 | Default \df{".oak"}. This variable is in the compiler locale.} 39 | 40 | \gv{compiler-to-extension} 41 | \doc{The extension the the output files the compiler will produce. 42 | Default \df{".oa"}. This variable is in the compiler locale.} 43 | 44 | \gv{compiler-noisiness} 45 | \doc{The amount of noise the compiler should produce; zero for none, 1 46 | for a little, and 2 for a lot. Default value is 1, but the 47 | \df{oakliszt} batch file compiler sets it to zero. This variable is 48 | in the compiler locale.} 49 | 50 | 51 | \subsection{Object File Formats} 52 | 53 | 54 | \subsection{Compiler Internals} 55 | 56 | Some compiler internals documentation. Very sketchy, just enough to 57 | give people a vague idea of what the internal program representation 58 | is and what the various passes are for. 59 | -------------------------------------------------------------------------------- /doc/lim/cover.tex: -------------------------------------------------------------------------------- 1 | % This file is part of Oaklisp. 2 | % 3 | % This program is free software; you can redistribute it and/or modify 4 | % it under the terms of the GNU General Public License as published by 5 | % the Free Software Foundation; either version 2 of the License, or 6 | % (at your option) any later version. 7 | % 8 | % This program is distributed in the hope that it will be useful, 9 | % but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | % GNU General Public License for more details. 12 | % 13 | % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | % or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | % Boston, MA 02111-1307, USA 16 | 17 | 18 | \begin{titlepage} 19 | 20 | \begin{center} 21 | 22 | \vspace*{1in} 23 | 24 | \Huge 25 | The \\ 26 | Oaklisp Implementation Guide \\ 27 | 28 | \vspace{.5in} 29 | 30 | \large 31 | \today \\ 32 | 33 | \vspace{.25in} 34 | 35 | \Huge 36 | DRAFT \\ 37 | 38 | \vspace{.5in} 39 | 40 | \Large 41 | Barak A. Pearlmutter \\ 42 | \large 43 | Dept.\ of Computer Science\\ 44 | Maynooth University\\ 45 | Co.\ Kildare\\ 46 | Ireland\\ 47 | \url{barak+oaklisp@pearlmutter.net} 48 | 49 | \vspace{.5in} 50 | 51 | \Large 52 | Kevin J. Lang \\ 53 | \large 54 | Yahoo!\ Research \\ 55 | \url{langk@yahoo-inc.com} 56 | 57 | \vfill 58 | 59 | \vspace{0.25in} 60 | 61 | The information in this document is subject to change at any time. 62 | 63 | \end{center} 64 | 65 | \end{titlepage} 66 | 67 | 68 | \thispagestyle{empty} 69 | 70 | \vspace*{6in} 71 | 72 | \normalsize 73 | \noindent Copyright \copyright 1985, 1986, 1987, 1988, 1989 74 | by Barak A. Pearlmutter and Kevin J. Lang. 75 | 76 | 77 | \newpage 78 | 79 | \pagenumbering{roman} 80 | 81 | 82 | -------------------------------------------------------------------------------- /doc/lim/intro.tex: -------------------------------------------------------------------------------- 1 | % This file is part of Oaklisp. 2 | % 3 | % This program is free software; you can redistribute it and/or modify 4 | % it under the terms of the GNU General Public License as published by 5 | % the Free Software Foundation; either version 2 of the License, or 6 | % (at your option) any later version. 7 | % 8 | % This program is distributed in the hope that it will be useful, 9 | % but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | % GNU General Public License for more details. 12 | % 13 | % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | % or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | % Boston, MA 02111-1307, USA 16 | 17 | 18 | 19 | \chapter{Introduction} 20 | 21 | This document describes the internals of the CMU implementation of 22 | Oaklisp. Although this implementation is designed for portability 23 | through the use of a bytecode interpreter written in C, the 24 | fundemental data structures and memory formats would also be suitable 25 | for a high performance implementation. In spite of the fact that 26 | Oaklisp has the potential performance penalty of being uniformly 27 | object-oriented, this implementation has proven more than competitive 28 | with other bytecode based implementations of Scheme, such at MIT's 29 | CScheme and Semantic Microsystems' MacScheme. An abbreviated version 30 | of some of the information presented here is available as a book 31 | chapter \citep{PEARLMUTTER-LANG90A}. 32 | 33 | \section{Disclaimer} 34 | 35 | \emph{Warning:} this document may contain inaccuracies, and it lags 36 | behind the implementation as the system evolves. 37 | -------------------------------------------------------------------------------- /doc/lim/lim.tex: -------------------------------------------------------------------------------- 1 | % This file is part of Oaklisp. 2 | % 3 | % This program is free software; you can redistribute it and/or modify 4 | % it under the terms of the GNU General Public License as published by 5 | % the Free Software Foundation; either version 2 of the License, or 6 | % (at your option) any later version. 7 | % 8 | % This program is distributed in the hope that it will be useful, 9 | % but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | % GNU General Public License for more details. 12 | % 13 | % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | % or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | % Boston, MA 02111-1307, USA 16 | 17 | 18 | \documentclass[12pt]{report} % Blake McBride suggests [...,twoside]{book} 19 | \usepackage{times} 20 | \usepackage{fullpage} 21 | \usepackage{graphicx} 22 | \usepackage{makeidx} 23 | \usepackage[numbers]{natbib} 24 | \usepackage[hyphens]{url} 25 | \urlstyle{same} 26 | 27 | % \includeonly{cover,intro,language,dataform,bytecode,stack,oaklevel} 28 | 29 | \makeindex 30 | 31 | \begin{document} 32 | 33 | \input{../mandefs} 34 | 35 | \include{cover} 36 | \tableofcontents 37 | \newpage 38 | \pagenumbering{arabic} 39 | \include{intro} 40 | \include{language} 41 | \include{dataform} 42 | \include{bytecode} 43 | \include{stack} 44 | \include{methods} 45 | \include{oaklevel} 46 | \include{compiler} 47 | \include{boot} 48 | \include{admin} 49 | 50 | \bibliography{../oakman} 51 | 52 | \printindex 53 | 54 | \end{document} 55 | -------------------------------------------------------------------------------- /doc/oaklisp-oopsla-1986.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/barak/oaklisp/0fb7ff88289dc10985749ada33e74b5e7db2ed20/doc/oaklisp-oopsla-1986.pdf -------------------------------------------------------------------------------- /m4/ax_append_flag.m4: -------------------------------------------------------------------------------- 1 | # =========================================================================== 2 | # http://www.gnu.org/software/autoconf-archive/ax_append_flag.html 3 | # =========================================================================== 4 | # 5 | # SYNOPSIS 6 | # 7 | # AX_APPEND_FLAG(FLAG, [FLAGS-VARIABLE]) 8 | # 9 | # DESCRIPTION 10 | # 11 | # FLAG is appended to the FLAGS-VARIABLE shell variable, with a space 12 | # added in between. 13 | # 14 | # If FLAGS-VARIABLE is not specified, the current language's flags (e.g. 15 | # CFLAGS) is used. FLAGS-VARIABLE is not changed if it already contains 16 | # FLAG. If FLAGS-VARIABLE is unset in the shell, it is set to exactly 17 | # FLAG. 18 | # 19 | # NOTE: Implementation based on AX_CFLAGS_GCC_OPTION. 20 | # 21 | # LICENSE 22 | # 23 | # Copyright (c) 2008 Guido U. Draheim 24 | # Copyright (c) 2011 Maarten Bosmans 25 | # 26 | # This program is free software: you can redistribute it and/or modify it 27 | # under the terms of the GNU General Public License as published by the 28 | # Free Software Foundation, either version 3 of the License, or (at your 29 | # option) any later version. 30 | # 31 | # This program is distributed in the hope that it will be useful, but 32 | # WITHOUT ANY WARRANTY; without even the implied warranty of 33 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 34 | # Public License for more details. 35 | # 36 | # You should have received a copy of the GNU General Public License along 37 | # with this program. If not, see . 38 | # 39 | # As a special exception, the respective Autoconf Macro's copyright owner 40 | # gives unlimited permission to copy, distribute and modify the configure 41 | # scripts that are the output of Autoconf when processing the Macro. You 42 | # need not follow the terms of the GNU General Public License when using 43 | # or distributing such scripts, even though portions of the text of the 44 | # Macro appear in them. The GNU General Public License (GPL) does govern 45 | # all other use of the material that constitutes the Autoconf Macro. 46 | # 47 | # This special exception to the GPL applies to versions of the Autoconf 48 | # Macro released by the Autoconf Archive. When you make and distribute a 49 | # modified version of the Autoconf Macro, you may extend this special 50 | # exception to the GPL to apply to your modified version as well. 51 | 52 | #serial 2 53 | 54 | AC_DEFUN([AX_APPEND_FLAG], 55 | [AC_PREREQ(2.59)dnl for _AC_LANG_PREFIX 56 | AS_VAR_PUSHDEF([FLAGS], [m4_default($2,_AC_LANG_PREFIX[FLAGS])])dnl 57 | AS_VAR_SET_IF(FLAGS, 58 | [case " AS_VAR_GET(FLAGS) " in 59 | *" $1 "*) 60 | AC_RUN_LOG([: FLAGS already contains $1]) 61 | ;; 62 | *) 63 | AC_RUN_LOG([: FLAGS="$FLAGS $1"]) 64 | AS_VAR_SET(FLAGS, ["AS_VAR_GET(FLAGS) $1"]) 65 | ;; 66 | esac], 67 | [AS_VAR_SET(FLAGS,["$1"])]) 68 | AS_VAR_POPDEF([FLAGS])dnl 69 | ])dnl AX_APPEND_FLAG 70 | -------------------------------------------------------------------------------- /m4/ax_c_long_long.m4: -------------------------------------------------------------------------------- 1 | # =========================================================================== 2 | # http://www.gnu.org/software/autoconf-archive/ax_c_long_long.html 3 | # =========================================================================== 4 | # 5 | # SYNOPSIS 6 | # 7 | # AX_C_LONG_LONG 8 | # 9 | # DESCRIPTION 10 | # 11 | # Provides a test for the existence of the long long int type and defines 12 | # HAVE_LONG_LONG if it is found. 13 | # 14 | # LICENSE 15 | # 16 | # Copyright (c) 2008 Caolan McNamara 17 | # 18 | # Copying and distribution of this file, with or without modification, are 19 | # permitted in any medium without royalty provided the copyright notice 20 | # and this notice are preserved. This file is offered as-is, without any 21 | # warranty. 22 | 23 | #serial 5 24 | 25 | AU_ALIAS([AC_C_LONG_LONG], [AX_C_LONG_LONG]) 26 | AC_DEFUN([AX_C_LONG_LONG], 27 | [AC_CACHE_CHECK(for long long int, ac_cv_c_long_long, 28 | [if test "$GCC" = yes; then 29 | ac_cv_c_long_long=yes 30 | else 31 | AC_TRY_COMPILE(,[long long int i;], 32 | ac_cv_c_long_long=yes, 33 | ac_cv_c_long_long=no) 34 | fi]) 35 | if test $ac_cv_c_long_long = yes; then 36 | AC_DEFINE(HAVE_LONG_LONG, 1, [compiler understands long long]) 37 | fi 38 | ]) 39 | -------------------------------------------------------------------------------- /m4/ax_require_defined.m4: -------------------------------------------------------------------------------- 1 | # =========================================================================== 2 | # http://www.gnu.org/software/autoconf-archive/ax_require_defined.html 3 | # =========================================================================== 4 | # 5 | # SYNOPSIS 6 | # 7 | # AX_REQUIRE_DEFINED(MACRO) 8 | # 9 | # DESCRIPTION 10 | # 11 | # AX_REQUIRE_DEFINED is a simple helper for making sure other macros have 12 | # been defined and thus are available for use. This avoids random issues 13 | # where a macro isn't expanded. Instead the configure script emits a 14 | # non-fatal: 15 | # 16 | # ./configure: line 1673: AX_CFLAGS_WARN_ALL: command not found 17 | # 18 | # It's like AC_REQUIRE except it doesn't expand the required macro. 19 | # 20 | # Here's an example: 21 | # 22 | # AX_REQUIRE_DEFINED([AX_CHECK_LINK_FLAG]) 23 | # 24 | # LICENSE 25 | # 26 | # Copyright (c) 2014 Mike Frysinger 27 | # 28 | # Copying and distribution of this file, with or without modification, are 29 | # permitted in any medium without royalty provided the copyright notice 30 | # and this notice are preserved. This file is offered as-is, without any 31 | # warranty. 32 | 33 | #serial 1 34 | 35 | AC_DEFUN([AX_REQUIRE_DEFINED], [dnl 36 | m4_ifndef([$1], [m4_fatal([macro ]$1[ is not defined; is a m4 file missing?])]) 37 | ])dnl AX_REQUIRE_DEFINED 38 | -------------------------------------------------------------------------------- /man/Makefile.am: -------------------------------------------------------------------------------- 1 | # This file is part of Oaklisp. 2 | # 3 | # This program is free software; you can redistribute it and/or modify 4 | # it under the terms of the GNU General Public License as published by 5 | # the Free Software Foundation; either version 2 of the License, or 6 | # (at your option) any later version. 7 | # 8 | # This program is distributed in the hope that it will be useful, 9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | # GNU General Public License for more details. 12 | # 13 | # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | # or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | # Boston, MA 02111-1307, USA 16 | 17 | man_MANS = man1/oaklisp.1 18 | 19 | man1/oaklisp.1: man1/oaklisp.1.in 20 | $(SED) \ 21 | -e 's:[@]pkglibdir[@]:$(pkglibdir):g' \ 22 | -e 's:[@]pdfdir[@]:$(pdfdir):g' \ 23 | <$< >$@ 24 | 25 | EXTRA_DIST = $(man_MANS) 26 | 27 | CLEANFILES = $(man_MANS) 28 | -------------------------------------------------------------------------------- /prebuilt/doc/lang/lang.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/barak/oaklisp/0fb7ff88289dc10985749ada33e74b5e7db2ed20/prebuilt/doc/lang/lang.pdf -------------------------------------------------------------------------------- /prebuilt/doc/lim/lim.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/barak/oaklisp/0fb7ff88289dc10985749ada33e74b5e7db2ed20/prebuilt/doc/lim/lim.pdf -------------------------------------------------------------------------------- /prebuilt/doc/summary/OaklispSummary.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/barak/oaklisp/0fb7ff88289dc10985749ada33e74b5e7db2ed20/prebuilt/doc/summary/OaklispSummary.pdf -------------------------------------------------------------------------------- /prebuilt/src/world/eb32/oakworld.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/barak/oaklisp/0fb7ff88289dc10985749ada33e74b5e7db2ed20/prebuilt/src/world/eb32/oakworld.bin -------------------------------------------------------------------------------- /prebuilt/src/world/el32/oakworld.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/barak/oaklisp/0fb7ff88289dc10985749ada33e74b5e7db2ed20/prebuilt/src/world/el32/oakworld.bin -------------------------------------------------------------------------------- /src/Makefile.am: -------------------------------------------------------------------------------- 1 | # This file is part of Oaklisp. 2 | # 3 | # This program is free software; you can redistribute it and/or modify 4 | # it under the terms of the GNU General Public License as published by 5 | # the Free Software Foundation; either version 2 of the License, or 6 | # (at your option) any later version. 7 | # 8 | # This program is distributed in the hope that it will be useful, 9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | # GNU General Public License for more details. 12 | # 13 | # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | # or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | # Boston, MA 02111-1307, USA 16 | 17 | SUBDIRS = emulator world 18 | 19 | EXTRA_DIST = misc/README misc/testing-tests.oak misc/uniq.oak \ 20 | misc/unit-testing.oak 21 | -------------------------------------------------------------------------------- /src/emulator/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | /instr-data.c 3 | /oaklisp 4 | -------------------------------------------------------------------------------- /src/emulator/Makefile.am: -------------------------------------------------------------------------------- 1 | # This file is part of Oaklisp. 2 | # 3 | # This program is free software; you can redistribute it and/or modify 4 | # it under the terms of the GNU General Public License as published by 5 | # the Free Software Foundation; either version 2 of the License, or 6 | # (at your option) any later version. 7 | # 8 | # This program is distributed in the hope that it will be useful, 9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | # GNU General Public License for more details. 12 | # 13 | # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | # or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | # Boston, MA 02111-1307, USA 16 | 17 | bin_PROGRAMS = oaklisp 18 | 19 | oaklisp_SOURCES = cmdline.c data.c gc.c instr.c loop.c oaklisp.c \ 20 | signals.c stacks.c threads.c timers.c weak.c worldio.c xmalloc.c \ 21 | cmdline.h config.h data.h gc.h instr.h loop.h signals.h stacks.h \ 22 | stacks-loop.h threads.h timers.h weak.h worldio.h xmalloc.h 23 | 24 | if NDEBUG 25 | else 26 | BUILT_SOURCES = instr-data.c 27 | endif 28 | 29 | oaklisp_CPPFLAGS = $(AM_CPPFLAGS) 30 | 31 | oaklisp_CPPFLAGS += -DDEFAULT_WORLD=\"$(pkglibdir)/oakworld.bin\" 32 | 33 | if ENABLE_THREADS 34 | oaklisp_CPPFLAGS += -DTHREADS 35 | endif 36 | 37 | if NDEBUG 38 | oaklisp_CPPFLAGS += -DFAST 39 | endif 40 | 41 | # Things to consider as configure.ac options: 42 | # oaklisp_CPPFLAGS += -DMAX_NEW_SPACE_SIZE=16000000 43 | 44 | # bootstrapping problem: to compile the emulator we need a working 45 | # oaklisp to generate instr-data.c. This is solved by trying to 46 | # generate it automatically if necessary, but if that fails instead 47 | # using a prebuilt copy. Note that when -DFAST is set instr-data.c is 48 | # not used and this is not an issue. 49 | 50 | OAK=oaklisp 51 | 52 | instr-data.c: instruction-table.oak 53 | $(OAK) $(OAKFLAGS) -- \ 54 | --locale compiler-locale \ 55 | --load "$<" \ 56 | --eval '(dump-instruction-table "$@")' \ 57 | --exit \ 58 | || cp ../prebuilt/src/emulator/instr-data.c $@ 59 | -$(INDENT) $@ 60 | 61 | EXTRA_DIST = instruction-table.oak instr-data.c 62 | 63 | CLEANFILES = instr-data.c 64 | -------------------------------------------------------------------------------- /src/emulator/cmdline.h: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | /********************************************************************** 19 | * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * 20 | * Copyright (c) by Alex Stuebinger, 1998-99. * 21 | * Distributed under the GNU General Public License v2 or later * 22 | **********************************************************************/ 23 | 24 | #ifndef _CMDLINE_H_INCLUDED 25 | #define _CMDLINE_H_INCLUDED 26 | 27 | extern void parse_cmd_line(int argc, char **argv); 28 | extern int program_arg_char(int arg_index, int char_index); 29 | 30 | #endif 31 | -------------------------------------------------------------------------------- /src/emulator/config.h: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | /********************************************************************** 19 | * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * 20 | * Copyright (c) by Alex Stuebinger, 1998-99. * 21 | * Distributed under the GNU General Public License v2 or later * 22 | **********************************************************************/ 23 | 24 | 25 | /* 26 | * Some configuration parameters explained: 27 | * ======================================== 28 | * 29 | * ASHR2 30 | * Must do arithmetic right shift on its argument. 31 | * Use ((x)/4) if your compiler generates logical shifts for 32 | * ((x)>>2) 33 | * 34 | * 35 | * THREADS 36 | * If defined, heavyweight OS pthreads are enabled. 37 | * 38 | */ 39 | 40 | #ifndef _CONFIG_H_INCLUDED 41 | #define _CONFIG_H_INCLUDED 42 | 43 | #ifdef HAVE_CONFIG_H 44 | #include "../../config.h" 45 | #endif 46 | 47 | #define ASHR2(x) ((x)>>2) 48 | 49 | #ifdef THREADS 50 | #ifndef MAX_THREAD_COUNT 51 | #define MAX_THREAD_COUNT 200 52 | #endif 53 | #endif 54 | 55 | /* Speed parameters */ 56 | 57 | /* Turn off most runtime debugging features that slow down the system. */ 58 | // #define FAST 59 | 60 | /* Toggle specific optimizations. */ 61 | 62 | /* Activate operation-method association list move-to-front. */ 63 | #ifndef THREADS 64 | #define OP_METH_ALIST_MTF 65 | #endif 66 | 67 | /* Activate operation-type method cache. */ 68 | #ifndef THREADS 69 | #define OP_TYPE_METH_CACHE 70 | #endif 71 | 72 | #endif 73 | -------------------------------------------------------------------------------- /src/emulator/data.c: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | /********************************************************************** 19 | * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * 20 | * Copyright (c) by Alex Stuebinger, 1998-99. * 21 | * Distributed under the GNU General Public License v2 or later * 22 | **********************************************************************/ 23 | 24 | /* This file contains many tunable parameters */ 25 | 26 | #define _REENTRANT 27 | 28 | #include "config.h" 29 | #include "data.h" 30 | #include "stacks.h" 31 | 32 | /* spaces */ 33 | 34 | space_t new_space, old_space, spatic; 35 | 36 | ref_t *free_point = 0; 37 | 38 | #ifndef THREADS 39 | /* stacks, including default buffer size & fill target */ 40 | oakstack value_stack = {1024, 1024/2}; 41 | oakstack context_stack = {512, 512/2}; 42 | #endif 43 | 44 | 45 | /* Virtual Machine registers */ 46 | #ifdef THREADS 47 | 48 | ref_t e_t, e_nil, e_fixnum_type, e_loc_type, e_cons_type, 49 | e_env_type, *e_subtype_table, e_object_type, e_segment_type, e_boot_code, 50 | *e_arged_tag_trap_table, *e_argless_tag_trap_table, 51 | e_uninitialized, e_method_type, e_operation_type = 0; 52 | size_t e_next_newspace_size; 53 | size_t original_newspace_size = 128 * 1024; 54 | 55 | #else 56 | 57 | ref_t *e_bp, *e_env, e_t, e_nil, e_fixnum_type, e_loc_type, e_cons_type, 58 | e_env_type, *e_subtype_table, e_object_type, e_segment_type, e_boot_code, 59 | e_code_segment, 60 | *e_arged_tag_trap_table, *e_argless_tag_trap_table, e_current_method, 61 | e_uninitialized, e_method_type, e_operation_type, e_process = 0; 62 | register_set_t *reg_set; 63 | size_t e_next_newspace_size; 64 | size_t original_newspace_size = DEFAULT_NEWSPACE * 1024; 65 | instr_t *e_pc; 66 | unsigned e_nargs = 0; 67 | 68 | #endif 69 | 70 | /* This should generally be defined in the Makefile */ 71 | #ifndef DEFAULT_WORLD 72 | #define DEFAULT_WORLD "/usr/lib/oaklisp/oakworld.bin" 73 | #endif 74 | 75 | char *world_file_name = DEFAULT_WORLD; 76 | char *dump_file_name = "oakworld-dump.bin"; 77 | int dump_base = 2; /* 2=binary, other=ascii */ 78 | bool dump_flag = false; 79 | 80 | int trace_gc = 0; 81 | -------------------------------------------------------------------------------- /src/emulator/gc.h: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | /********************************************************************** 19 | * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * 20 | * Copyright (c) by Alex Stuebinger, 1998-99. * 21 | * Distributed under the GNU General Public License v2 or later * 22 | **********************************************************************/ 23 | 24 | 25 | #ifndef _GC_H_INCLUDED 26 | #define _GC_H_INCLUDED 27 | 28 | #include "config.h" 29 | #include "data.h" 30 | 31 | extern bool full_gc; 32 | extern void printref(FILE * fd, ref_t refin); 33 | 34 | extern void gc(bool pre_dump, bool full_gc, char *reason, 35 | size_t amount); 36 | 37 | #define GC_MEMORY(v) \ 38 | {*gc_examine_ptr++ = (v);} 39 | /* 40 | assert(gc_examine_ptr < &gc_examine_buffer[GC_EXAMINE_BUFFER_SIZE]);\ 41 | } */ 42 | 43 | #define GC_RECALL(v) \ 44 | {(v) = *--gc_examine_ptr;} 45 | /* 46 | assert(gc_examine_ptr >= gc_examine_buffer);\ 47 | } */ 48 | 49 | #ifdef THREADS 50 | extern int gc_ready[]; 51 | extern bool gc_pending; 52 | extern pthread_mutex_t gc_lock; 53 | #endif 54 | 55 | extern void set_gc_flag (bool flag); 56 | extern int get_next_index(); 57 | extern void free_registers(); 58 | extern void wait_for_gc(); 59 | 60 | #endif 61 | -------------------------------------------------------------------------------- /src/emulator/instr.c: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | #define _REENTRANT 19 | 20 | #include "data.h" 21 | 22 | #ifndef FAST 23 | 24 | #include 25 | 26 | #include "instr-data.c" 27 | 28 | void 29 | print_pc(instr_t *e_progc) 30 | { 31 | if (SPATIC_PTR((ref_t *) e_progc)) 32 | fprintf(stdout, "%7ld[spatic] ", 33 | (long)((char *)e_progc - (char *)spatic.start)); 34 | else 35 | fprintf(stdout, "%7ld[new ] ", 36 | (long)((char *)e_progc - (char *)new_space.start 37 | + 4 * spatic.size)); 38 | } 39 | 40 | void 41 | print_instr(int op_field, int arg_field, instr_t *e_progc) 42 | { 43 | print_pc(e_progc); 44 | 45 | if (op_field == 0) 46 | fprintf(stdout, "%s\n", argless_instr_name[arg_field]); 47 | else 48 | fprintf(stdout, "%s %d\n", instr_name[op_field], arg_field); 49 | } 50 | 51 | #endif 52 | -------------------------------------------------------------------------------- /src/emulator/instr.h: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | #ifndef _INSTR_H_INCLUDED 19 | #define _INSTR_H_INCLUDED 20 | #ifndef FAST 21 | extern void print_instr(int /* op_field */, int /* arg_field */, instr_t * /* e_pc */); 22 | extern void print_pc(instr_t * /* e_pc */); 23 | #endif 24 | #endif 25 | -------------------------------------------------------------------------------- /src/emulator/instruction-table.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | ;;; Copyright (C) 1988-2008 Kevin J. Lang & Barak A. Pearlmutter 18 | 19 | ;;; Dump a table of all the instructions in a format suitable for 20 | ;;; compilation into the emulator. 21 | 22 | (let ((aux (lambda (s instr i) 23 | (format s " \"~S\"," instr) 24 | (if (= (modulo i 10) 0) 25 | (format s " /* ~D */~%" i) 26 | (format s "~%"))))) 27 | 28 | (define (dump-instruction-table f) 29 | 30 | (let ((t0 (make simple-vector %argless-instructions)) 31 | (t1 (make simple-vector %arged-instructions))) 32 | 33 | (dotimes (i %argless-instructions) 34 | (set! (nth t0 i) (#^symbol (format #f "ILLEGAL-ARGLESS-~d" i)))) 35 | 36 | (dotimes (i %arged-instructions) 37 | (set! (nth t1 i) (#^symbol (format #f "ILLEGAL-ARGED-~d" i)))) 38 | 39 | (dolist (x (#^list-type opcode-descriptor-hash-table)) 40 | (destructure* (instr opcode argfield . #t) x 41 | (cond ((= opcode 0) (set! (nth t0 argfield) instr)) 42 | (else (set! (nth t1 opcode) instr))))) 43 | 44 | (with-open-file (s f out) 45 | 46 | (format s "// Automatically generated by instruction-table.oak~%~%") 47 | 48 | (format s "char *argless_instr_name[] = {~%") 49 | (dotimes (i %argless-instructions) 50 | (aux s (nth t0 i) i)) 51 | (format s "};~%~%") 52 | 53 | (format s "char *instr_name[] = {~%") 54 | (dotimes (i %arged-instructions) 55 | (aux s (nth t1 i) i)) 56 | (format s "};~%"))))) 57 | -------------------------------------------------------------------------------- /src/emulator/loop.h: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | /********************************************************************** 19 | * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * 20 | * Copyright (c) by Alex Stuebinger, 1998-99. * 21 | * Distributed under the GNU General Public License v2 or later * 22 | **********************************************************************/ 23 | 24 | 25 | #ifndef _LOOP_H_INCLUDED 26 | #define _LOOP_H_INCLUDED 27 | #include "data.h" 28 | extern void loop(ref_t); 29 | 30 | #endif 31 | -------------------------------------------------------------------------------- /src/emulator/signals.c: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | /********************************************************************** 19 | * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * 20 | * Copyright (c) by Alex Stuebinger, 1998-99. * 21 | * Distributed under the GNU General Public License v2 or later * 22 | **********************************************************************/ 23 | 24 | 25 | /* Handle signals by polling. In order to do this 26 | signal_poll_flag is set to > 0 when a signal comes in, and is 27 | checked and reset by the bytecode emulator at frequent intervals 28 | when it is safe to field an interrupt. 29 | 30 | BUG: This can delay interrupt handling when waiting for input. 31 | */ 32 | 33 | #define _REENTRANT 34 | 35 | #include 36 | #include 37 | #include 38 | #include 39 | #include "config.h" 40 | #include "signals.h" 41 | 42 | 43 | 44 | int signal_poll_flag = 0; 45 | 46 | static void 47 | intr_proc(int sig) 48 | { 49 | signal_poll_flag++; 50 | } 51 | 52 | 53 | void 54 | enable_signal_polling(void) 55 | { 56 | signal_poll_flag = 0; 57 | if (signal(SIGINT, intr_proc) == SIG_ERR) 58 | fprintf(stderr, "Cannot enable signal polling.\n"); 59 | } 60 | 61 | #if 0 /* the following is not used and commented out */ 62 | 63 | void 64 | disable_signal_polling(void) 65 | { 66 | signal_poll_flag = 0; 67 | if (signal(SIGINT, SIG_DFL) == SIG_ERR) 68 | fprintf(stderr, "Cannot disable signal polling.\n"); 69 | } 70 | 71 | void 72 | clear_signal(void) 73 | { 74 | signal_poll_flag = 0; 75 | } 76 | #endif /* commented out */ 77 | -------------------------------------------------------------------------------- /src/emulator/signals.h: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | /********************************************************************** 19 | * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * 20 | * Copyright (c) by Alex Stuebinger, 1998-99. * 21 | * Distributed under the GNU General Public License v2 or later * 22 | **********************************************************************/ 23 | 24 | 25 | #ifndef _SIGNAL_H_INCLUDED 26 | #define _SIGNAL_H_INCLUDED 27 | 28 | void enable_signal_polling(void); 29 | void disable_signal_polling(void); 30 | void clear_signal(void); 31 | extern int signal_poll_flag; 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /src/emulator/stacks.h: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | /********************************************************************** 19 | * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * 20 | * Copyright (c) by Alex Stuebinger, 1998-99. * 21 | * Distributed under the GNU General Public License v2 or later * 22 | **********************************************************************/ 23 | 24 | #ifndef _STACKS_H_INCLUDED 25 | #define _STACKS_H_INCLUDED 26 | 27 | #include "config.h" 28 | #include "gc.h" 29 | #include "data.h" 30 | 31 | extern int max_segment_size; 32 | 33 | 34 | /* flushed stack segment. Allocated and gc'ed in the oaklisp heap. */ 35 | typedef struct { 36 | /* Do not rearange this structure or you'll be sorry! */ 37 | ref_t type_field; 38 | ref_t length_field; 39 | ref_t previous_segment; 40 | ref_t data[1]; 41 | } segment_t; 42 | 43 | #define SEGMENT_HEADER_LENGTH (sizeof(segment_t)/sizeof(ref_t)-1) 44 | 45 | /* stack type */ 46 | 47 | typedef struct { 48 | int size; /* size of stack buffer */ 49 | int filltarget; /* how high to fill buffer ideally */ 50 | ref_t *bp; /* pointer to this stack's "buffer" */ 51 | ref_t *sp; /* pointer to top element in stack */ 52 | ref_t segment; /* head of linked list of flushed segments */ 53 | int pushed_count; /* number of ref's in flushed segment list */ 54 | } oakstack; 55 | 56 | #ifdef THREADS 57 | extern oakstack *value_stack_array[]; 58 | extern oakstack *cntxt_stack_array[]; 59 | #else 60 | extern oakstack value_stack; 61 | extern oakstack context_stack; 62 | #endif 63 | 64 | extern void init_stacks(void); 65 | extern void stack_flush(oakstack * stack_p, int amount_to_leave); 66 | extern void stack_unflush(oakstack * stack_p, int n); 67 | extern void dump_stack(oakstack * stack_p); 68 | 69 | #endif 70 | -------------------------------------------------------------------------------- /src/emulator/threads.h: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | #ifndef _THREADS_H_INCLUDED 19 | #define _THREADS_H_INCLUDED 20 | 21 | #include 22 | #include "config.h" 23 | 24 | #ifdef THREADS 25 | extern int next_index; 26 | extern pthread_key_t index_key; 27 | extern pthread_mutex_t index_lock; 28 | extern pthread_mutex_t alloc_lock; 29 | extern pthread_mutex_t test_and_set_locative_lock; 30 | #endif 31 | 32 | 33 | 34 | #ifdef THREADS 35 | #define THREADY(x) x 36 | #else 37 | #define THREADY(x) 38 | #endif 39 | 40 | #endif /*_THREADS_H_INCLUDED*/ 41 | -------------------------------------------------------------------------------- /src/emulator/timers.h: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | /********************************************************************** 19 | * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * 20 | * Copyright (c) by Alex Stuebinger, 1998-99. * 21 | * Distributed under the GNU General Public License v2 or later * 22 | **********************************************************************/ 23 | 24 | #ifndef _TIMERS_H_INCLUDED 25 | #define _TIMERS_H_INCLUDED 26 | 27 | /* the functions return milliseconds */ 28 | 29 | extern unsigned long get_real_time(void); 30 | extern unsigned long get_user_time(void); 31 | 32 | #endif 33 | -------------------------------------------------------------------------------- /src/emulator/weak.h: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | /********************************************************************** 19 | * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * 20 | * Copyright (c) by Alex Stuebinger, 1998-99. * 21 | * Distributed under the GNU General Public License v2 or later * 22 | **********************************************************************/ 23 | 24 | 25 | #ifndef _WEAK_H_INCLUDED 26 | #define _WEAK_H_INCLUDED 27 | 28 | #include "data.h" 29 | 30 | void init_weakpointer_tables(void); 31 | void rebuild_wp_hashtable(void); 32 | ref_t ref_to_wp(ref_t r); 33 | extern unsigned long post_gc_wp(void); 34 | 35 | /* Weak pointer table and weak pointer hashtable */ 36 | 37 | extern const int wp_table_size, wp_hashtable_size; 38 | extern ref_t *wp_table; 39 | extern int wp_index; 40 | 41 | #endif 42 | -------------------------------------------------------------------------------- /src/emulator/worldio.h: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | /********************************************************************** 19 | * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * 20 | * Copyright (c) by Alex Stuebinger, 1998-99. * 21 | * Distributed under the GNU General Public License v2 or later * 22 | **********************************************************************/ 23 | 24 | 25 | #ifndef _WORLDIO_H_INCLUDED 26 | #define _WORLDIO_H_INCLUDED 27 | 28 | extern void dump_world(bool justnew); 29 | extern void read_world(char *string); 30 | 31 | #endif 32 | -------------------------------------------------------------------------------- /src/emulator/xmalloc.h: -------------------------------------------------------------------------------- 1 | // This file is part of Oaklisp. 2 | // 3 | // This program is free software; you can redistribute it and/or 4 | // modify it under the terms of the GNU General Public License as 5 | // published by the Free Software Foundation; either version 2 of the 6 | // License, or (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | // or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | // Boston, MA 02111-1307, USA 16 | 17 | 18 | /********************************************************************** 19 | * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * 20 | * Copyright (c) by Alex Stuebinger, 1998-99. * 21 | * Distributed under the GNU General Public License v2 or later * 22 | **********************************************************************/ 23 | 24 | #ifndef _XMALLOC_H_INCLUDED 25 | #define _XMALLOC_H_INCLUDED 26 | 27 | #include 28 | #include "data.h" 29 | 30 | extern void *xmalloc(size_t size); 31 | extern void alloc_space(space_t * pspace, size_t size_requested); 32 | extern void free_space(space_t * pspace); 33 | extern void realloc_space(space_t * pspace, size_t size_requested); 34 | char *oak_c_string(ref_t * oakstr, int len); 35 | 36 | #endif 37 | -------------------------------------------------------------------------------- /src/misc/README: -------------------------------------------------------------------------------- 1 | Miscellaneous material: contributed etc. 2 | -------------------------------------------------------------------------------- /src/misc/testing-tests.oak: -------------------------------------------------------------------------------- 1 | ;;; From: Ken Kickey 2 | 3 | ;; (require 'unit-testing) ;; (load "unit-testing.oak") 4 | 5 | (add-eq-test 'one #t (= 1 1) "equal") 6 | 7 | (add-eq-test 'one #f (< 2 1) "less") 8 | 9 | (add-eq-test 'one 'foo (intern "FOO") "eq?") ;; interning case is UPPER 10 | 11 | (add-equal-test 'one "FOO" ((coercer string) 'foo) "equal?") 12 | 13 | (add-test 'one 37 (+ 36 1) = "addition") 14 | 15 | (add-test 'two 54 (max 32 1 54 7 23 7 21) = "max") 16 | 17 | (add-test 'two 'yes (if (> 2 1) 'yes 'no) eq? "if") 18 | 19 | ;;(add-test 'two 'error-failure (if (> 2 1) 'yes 'no) eq? "if failure") 20 | 21 | (ensure-exception-raised 'two generic-fatal-error (/ 7 0) "zero divisor exception") 22 | 23 | ;;(set! (verbose? unit-tests) #t) 24 | ;;(run-all-tests unit-tests) 25 | 26 | ;; EOF ;; 27 | -------------------------------------------------------------------------------- /src/misc/uniq.oak: -------------------------------------------------------------------------------- 1 | (define (uniq lis) 2 | (do ((alist '() 3 | (let ((x (car lis))) 4 | (cond ((assoc x alist) 5 | => (lambda (p) 6 | (set! (cdr p) (+ (cdr p) 1)) 7 | alist)) 8 | (else (cons (cons x 1) alist))))) 9 | (lis lis (cdr lis))) 10 | ((null? lis) alist))) 11 | -------------------------------------------------------------------------------- /src/world/.gitignore: -------------------------------------------------------------------------------- 1 | *.bin 2 | *.cold 3 | *.oa 4 | *.sym 5 | -------------------------------------------------------------------------------- /src/world/alarm.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;; 19 | ;; 20 | ;; Handles alarm traps which are arbitrarily generated by the bytecode 21 | ;; emulator. 22 | ;; 23 | 24 | #| 25 | (define (alarm n) 26 | (%disable-alarms) 27 | (format #t "*Bing*") 28 | (set! ((%register 'nargs)) n) 29 | (%reset-alarm-counter) 30 | (%enable-alarms) 31 | (%return)) 32 | |# 33 | 34 | (define alarm (add-method ((make operation) n) 35 | (pause) 36 | (set! ((%register 'nargs)) n) 37 | (%return))) 38 | 39 | ;;; avoid forward reference in tag-trap.oak 40 | (set! (nth %argless-tag-trap-table 127) alarm) 41 | 42 | ;; 43 | ;; Define atomic functions (op-codes) for turning alarms on and off. 44 | ;; 45 | (define-constant %enable-alarms 46 | (add-method ((make-open-coded-operation '((enable-alarms)) 0 1) 47 | (object)) 48 | (%enable-alarms))) 49 | 50 | (define-constant %disable-alarms 51 | (add-method ((make-open-coded-operation '((disable-alarms)) 0 1) 52 | (object)) 53 | (%disable-alarms))) 54 | 55 | (define-constant %reset-alarm-counter 56 | (add-method ((make-open-coded-operation '((reset-alarm-counter)) 0 1) 57 | (object)) 58 | (%reset-alarm-counter))) 59 | -------------------------------------------------------------------------------- /src/world/apropos.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (define-instance apropos operation) 21 | 22 | (with-operations (apropos2) 23 | 24 | (let ((check-in-list-and-print 25 | (lambda (place list-of-pairs key) 26 | (let ((skey (upcase (#^string key)))) 27 | (bind ((#*fancy-references #t)) 28 | (format #t "~&In ~A:~%" place)) 29 | (dolist (x list-of-pairs) 30 | (when (subsequence? skey (#^string (car x))) 31 | (format #t " ~A~%" (car x)))))))) 32 | 33 | (add-method (apropos (object) key . args) 34 | (cond ((= 0 (rest-length args)) 35 | (apropos2 #*current-locale key)) 36 | ((= 1 (rest-length args)) 37 | (apropos2 key . args)) 38 | (else 39 | (error "try (apropos ) ")))) 40 | 41 | (add-method (apropos2 (object) key place) 42 | (error "try (apropos ).~%")) 43 | 44 | (add-method (apropos2 (symbol) key place) (apropos2 place key)) 45 | (add-method (apropos2 (string) key place) (apropos2 place key)) 46 | 47 | (add-method (apropos2 (locale variable-table macro-alist) self key) 48 | (check-in-list-and-print self (#^list-type variable-table) key) 49 | (check-in-list-and-print "macro table" macro-alist key) 50 | (check-in-list-and-print "top level fluid variables" 51 | top-level-fluid-binding-list key)) 52 | 53 | (add-method (apropos2 (hash-table) self key) 54 | (check-in-list-and-print self (#^list-type self) key)))) 55 | 56 | ;;; eof 57 | -------------------------------------------------------------------------------- /src/world/bignum2.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter. 19 | 20 | 21 | (define (bignum-speed-test) 22 | (set frog1 (apply * (subseq prime-list 0 60))) 23 | (set frog2 (apply * (subseq prime-list 60 45))) 24 | (set frog3 (* frog1 frog2)) 25 | (set frog4 (make bignum 1 (reverse (bignum-digits frog3)))) 26 | (%gc) 27 | (set junk (quotient frog1 123456)) 28 | (map quotient 29 | (list 30 | (time (10) (+ frog3 frog4)) 31 | (time (10) (- frog3 frog4)) 32 | (time (5) (* frog1 frog2)) 33 | (time (1) (quotient frog4 frog2))) 34 | '(1000 1000 1000 1000))) 35 | 36 | 37 | 38 | 39 | ; (), 1, (1 . 2), ((2 . 3) . 1), ((1 . 4) . (2 . 3)) 40 | 41 | (define-instance insert-balanced-tree operation) 42 | 43 | (add-method (insert-balanced-tree (null-type) self new) 44 | new) 45 | 46 | (add-method (insert-balanced-tree (object) self new) 47 | (cons self new)) 48 | 49 | (add-method (insert-balanced-tree (cons-pair the-car the-cdr) self new) 50 | (let ((old-car the-car)) 51 | (set! the-car (insert-balanced-tree the-cdr new)) 52 | (set! the-cdr old-car)) 53 | self) 54 | 55 | 56 | (define-instance multiply-tree operation) 57 | 58 | (add-method (multiply-tree (null-type) self) 1) 59 | 60 | (add-method (multiply-tree (object) self) self) 61 | 62 | (add-method (multiply-tree (cons-pair the-car the-cdr) self) 63 | (* (multiply-tree the-car) 64 | (multiply-tree the-cdr))) 65 | 66 | 67 | (define (fact n) 68 | (iterate next ((n n)(tree '())) 69 | (if (zero? n) 70 | (multiply-tree tree) 71 | (next (- n 1)(insert-balanced-tree tree n))))) 72 | 73 | ;;; eof 74 | -------------------------------------------------------------------------------- /src/world/booted.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; We're up enough now to attempt a read-eval-print loop upon reboot. 21 | 22 | (define (%get-an-ivar t o v) 23 | (contents (car (%locate-ivars t o (list v))))) 24 | 25 | (let* ((reboot-lambda 26 | 27 | (lambda () 28 | (set! ((%register 'nil)) (the-runtime nil)) 29 | (set! ((%register 't)) (the-runtime t)) 30 | (set! ((%register 'cons-type)) (the-runtime cons-pair)) 31 | (set! ((%register 'object-type)) (the-runtime object)) 32 | (set! ((%register 'fixnum-type)) (the-runtime fixnum)) 33 | (set! ((%register 'loc-type)) (the-runtime locative)) 34 | (set! ((%register 'env-type)) (the-runtime %closed-environment)) 35 | (set! ((%register 'segment-type)) (the-runtime stack-segment)) 36 | (set! ((%register 'method-type)) (the-runtime %method)) 37 | (set! ((%register 'operation-type)) (the-runtime operation)) 38 | 39 | (warm-boot) 40 | ;; (format t "warm boot actions ~S~%" warm-boot-actions) 41 | (top-level))) 42 | 43 | (reboot-method (%get-an-ivar operation reboot-lambda 'lambda?))) 44 | (set! ((%register 'boot-code)) reboot-method)) 45 | -------------------------------------------------------------------------------- /src/world/bounders.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (define-instance find-bound-vars operation) 21 | 22 | (define-instance find-vars operation) 23 | 24 | (define-instance for-each-r operation) 25 | 26 | (add-method (for-each-r (eq-hash-table table) self op) 27 | (let ((op (lambda (x) 28 | (op (car x) (cdr x))))) 29 | (dotimes (i (length table)) 30 | (for-each op (nth table i))))) 31 | 32 | (add-method (find-bound-vars (locale variable-table) self val) 33 | (for-each-r variable-table 34 | (lambda (sym cell) 35 | (when (eq? (contents cell) val) 36 | (format #t "~&~A's bound to that.~%" sym))))) 37 | 38 | (add-method (find-vars (locale variable-table) self pred?) 39 | (for-each-r variable-table 40 | (lambda (sym cell) 41 | (when (pred? (contents cell) sym) 42 | (format #t "~&~A (~A)~%" sym (contents cell)))))) 43 | 44 | 45 | (define-instance find-sorted-vars operation) 46 | 47 | (add-method (find-sorted-vars (locale variable-table) self pred?) 48 | (let ((outlist nil)) 49 | (for-each-r variable-table 50 | (lambda (sym cell) 51 | (when (pred? (contents cell) sym) 52 | (push outlist sym)))) 53 | (sort outlist (lambda (a b) 54 | (< (#^string a) (#^string b)))))) 55 | 56 | 57 | (define (find-and-print-sorted-vars locale pred?) 58 | (dolist (x (find-sorted-vars locale pred?)) 59 | (format #t "~&~A~%" x))) 60 | 61 | 62 | -------------------------------------------------------------------------------- /src/world/bp-alist.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter. 19 | 20 | (define-instance get-bp-alist operation) 21 | 22 | (add-method (get-bp-alist (type type-bp-alist) self) 23 | type-bp-alist) 24 | -------------------------------------------------------------------------------- /src/world/cmdline-getopt.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1999 Barak A. Pearlmutter. 19 | 20 | ;;; This can be made more sophisticated later, with command completion etc. 21 | ;;; For now is is quite rudimentary. 22 | 23 | (define (getopt options args) 24 | (let aux ((args args)) 25 | (if (null? args) 26 | '() 27 | (cond ((strip-dashes (car args)) 28 | => (lambda (a) 29 | (cond ((ass equal? a options) 30 | => (lambda (o) 31 | (let ((n (cadr o)) 32 | (f (caddr o))) 33 | (let ((stuff (head (cdr args) n))) 34 | (catch-errors (general-error 35 | (lambda (err) 36 | (format standard-error 37 | "~&An error occurred while processing switch ~A args ~S~%" 38 | a stuff) 39 | (report err standard-error) 40 | (format standard-error "~%"))) 41 | (apply f stuff))) 42 | (aux (tail (cdr args) n))))) 43 | (else (format standard-error "~&error: unknown switch: ~A" a) 44 | (exit 1))))) 45 | (else args))))) 46 | 47 | (define (strip-dashes a) 48 | (let ((n (length a))) 49 | (and (> n 1) 50 | (equal? (nth a 0) #\-) 51 | (let ((dashlen (if (equal? (nth a 1) #\-) 2 1))) 52 | (and (> n dashlen) 53 | (subseq a dashlen (- n dashlen))))))) 54 | -------------------------------------------------------------------------------- /src/world/cmdline-options.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1999 Barak A. Pearlmutter. 19 | 20 | (define commandline-options 21 | `(("help" 0 ,(lambda () 22 | (format #t " 23 | Oaklisp level options. 24 | 25 | --help Print this message & exit. 26 | 27 | --eval expr Evaluate Oaklisp expression, which is one arg so 28 | be sure to quote for shell. 29 | 30 | --load file Load a file. 31 | 32 | --compile file Compile file.oak yielding file.oa 33 | 34 | --locale x Switch to locale x, eg system-locale (default), 35 | compiler-locale, scheme-locale (for RnRS 36 | compatibility). 37 | 38 | --pthreads Number of pthreads to allocate. 39 | 40 | --exit Exit upon processing this option. 41 | 42 | Example: 43 | oaklisp --trace-gc 2 -- --locale scheme-locale --compile myfile --exit 44 | ") 45 | (exit 0))) 46 | 47 | ("eval" 1 ,(lambda (x) 48 | (eval (read (make string-input-stream x)) 49 | #*current-locale))) 50 | 51 | ("load" 1 ,(lambda (x) 52 | (load x #*current-locale))) 53 | 54 | ("compile" 1 ,(lambda (x) 55 | (format #t "~&Compiling ~S..." x) 56 | (flush standard-output) 57 | (bind ((#*compiler-noisiness 0)) 58 | (compile-file #*current-locale 59 | x)) 60 | (format #t "...done.~%"))) 61 | 62 | ("locale" 1 ,(lambda (x) 63 | (set! #*current-locale 64 | (eval (read (make string-input-stream x)) 65 | #*current-locale)))) 66 | ("pthreads" 1 ,(lambda (x) 67 | (set! heavyweight-thread-count 68 | (read (make string-input-stream x))) 69 | (unless (integer? heavyweight-thread-count) 70 | (exit 1 "-pthread option takes integer argument.~%")))) 71 | ("exit" 0 ,(lambda () 72 | (exit 0 ""))))) 73 | 74 | (define (cmdline-eat) 75 | (set! argline 76 | (getopt commandline-options 77 | argline))) 78 | 79 | (add-warm-boot-action cmdline-eat) 80 | -------------------------------------------------------------------------------- /src/world/cmdline.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1999 Barak A. Pearlmutter 19 | 20 | (define (get-argv i) 21 | (let aux ((rchars '()) 22 | (j 0)) 23 | (let ((c (get-argline-char i j))) 24 | (cond ((eqv? c #\nul) 25 | (#^string (reverse rchars))) 26 | ((eqv? c #f) #f) 27 | (else (aux (cons c rchars) (+ j 1))))))) 28 | 29 | (define (get-argline) 30 | (let aux ((rargv '()) (i 0)) 31 | (let ((a (get-argv i))) 32 | (if a 33 | (aux (cons a rargv) 34 | (+ i 1)) 35 | (reverse rargv))))) 36 | 37 | (define argline '()) 38 | 39 | (define (fetch-argline) 40 | (set! argline (get-argline))) 41 | 42 | (add-warm-boot-action fetch-argline) 43 | -------------------------------------------------------------------------------- /src/world/coerce.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter. 19 | 20 | ;;; Define a kind of type that can be coerced to. Such types have a 21 | ;;; coercer operation, which can be applied to an instance of some other 22 | ;;; type in order to coerce it to this type. For example, to coerce a 23 | ;;; number X to floating point, write ((COERCER FLOAT) X) or, with read 24 | ;;; macros, (#^FLOAT X). 25 | 26 | ;;; This definition goes in "KERNEL" so primitive types can be coercable. 27 | ;(define-instance coercable-type type '(co-op) (list type)) 28 | 29 | (define-constant-instance coercer 30 | (mix-types oc-mixer (list foldable-mixin settable-operation))) 31 | 32 | (add-method (coercer (coercable-type co-op) self) 33 | co-op) 34 | 35 | (add-method ((setter coercer) (coercable-type co-op) self new-op) 36 | (set! co-op new-op)) 37 | 38 | ;;; eof 39 | -------------------------------------------------------------------------------- /src/world/cold-boot-end.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988, Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; This file goes at the end of the cold boot. 21 | 22 | 23 | ;;; Turn off the annoying alliterative ampersands. 24 | 25 | (set! monitor-for-bruce #f) 26 | 27 | ;;; Turn off the cold load streams so the whole concept will get GCed. 28 | 29 | (set! standard-input 0) 30 | (set! standard-output 0) 31 | 32 | (%write-char #\newline) 33 | (%write-char #\C) 34 | (%write-char #\o) 35 | (%write-char #\l) 36 | (%write-char #\d) 37 | (%write-char #\space) 38 | (%write-char #\b) 39 | (%write-char #\o) 40 | (%write-char #\o) 41 | (%write-char #\t) 42 | (%write-char #\e) 43 | (%write-char #\d) 44 | (%write-char #\.) 45 | (%write-char #\newline) 46 | (%write-char #\newline) 47 | (%write-char #\O) 48 | (%write-char #\a) 49 | (%write-char #\k) 50 | (%write-char #\l) 51 | (%write-char #\i) 52 | (%write-char #\s) 53 | (%write-char #\p) 54 | (%write-char #\space) 55 | (%write-char #\s) 56 | (%write-char #\t) 57 | (%write-char #\o) 58 | (%write-char #\p) 59 | (%write-char #\p) 60 | (%write-char #\e) 61 | (%write-char #\d) 62 | (%write-char #\space) 63 | (%write-char #\i) 64 | (%write-char #\t) 65 | (%write-char #\s) 66 | (%write-char #\e) 67 | (%write-char #\l) 68 | (%write-char #\f) 69 | (%write-char #\.) 70 | (%write-char #\.) 71 | (%write-char #\.) 72 | (%write-char #\newline) 73 | 74 | ;;; Halt so the world will dump. 75 | 76 | ((%halt 0)) 77 | 78 | 79 | ;;; eof 80 | -------------------------------------------------------------------------------- /src/world/cold-booting.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Barak A. Pearlmutter and Kevin J. Lang 19 | 20 | (%write-char #\C) 21 | (%write-char #\o) 22 | (%write-char #\l) 23 | (%write-char #\d) 24 | (%write-char #\space) 25 | (%write-char #\b) 26 | (%write-char #\o) 27 | (%write-char #\o) 28 | (%write-char #\t) 29 | (%write-char #\i) 30 | (%write-char #\n) 31 | (%write-char #\g) 32 | (%write-char #\space) 33 | (%write-char #\.) 34 | (%write-char #\.) 35 | (%write-char #\.) 36 | (%write-char #\newline) 37 | 38 | ;;; eof 39 | -------------------------------------------------------------------------------- /src/world/cold.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Barak A. Pearlmutter and Kevin J. Lang 19 | 20 | ;;; Define both input and output streams that might work during the cold 21 | ;;; load process, so we can have a gander at error messages and maybe poke 22 | ;;; about. 23 | 24 | (let ((cold-load-input-stream (make type '() (list input-stream object))) 25 | (cold-load-output-stream (make type '() (list output-stream object)))) 26 | 27 | (add-method (really-read-char (cold-load-input-stream) self) 28 | (%read-char)) 29 | 30 | (add-method (write-char (cold-load-output-stream) self char) 31 | (%write-char char)) 32 | 33 | (set! standard-input (make cold-load-input-stream)) 34 | (set! standard-output (make cold-load-output-stream))) 35 | 36 | ;;; eof 37 | -------------------------------------------------------------------------------- /src/world/compiler-exports.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1999 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | ;;; The last two variables exported might already be in system-locale 21 | ;;; due to forward references; hence the check. 22 | 23 | (dolist (v '(cc compile-file compile-code-fragment)) 24 | (when (not (variable-here? system-locale v)) 25 | (export-sharing-cell compiler-locale system-locale v))) 26 | 27 | ;;; eof 28 | -------------------------------------------------------------------------------- /src/world/da.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | (%write-char #\-) 19 | -------------------------------------------------------------------------------- /src/world/define.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Kevin J. Lang and Barak A. Pearlmutter 19 | 20 | ;;; Define define-constant and related forms. 21 | 22 | (define-syntax (define-constant var . body) 23 | `(block0 (define ,var . ,body) 24 | (freeze-in-current-locale 25 | ',(if (pair? var) (car var) var)))) 26 | 27 | (define-syntax (define-constant-instance var typ . args) 28 | `(block0 (define-instance ,var ,typ . ,args) 29 | (freeze-in-current-locale ',var))) 30 | 31 | ;;; eof 32 | -------------------------------------------------------------------------------- /src/world/del.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;;; Copyright (C) 1989 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | ;;; When a unix level DEL signal comes in, this is what gets signaled. 21 | 22 | (define-instance user-interrupt type '() (list proceedable-condition object)) 23 | 24 | (add-method (report (user-interrupt) self stream) 25 | (format stream "User interrupt.~%")) 26 | 27 | (add-method (initialize (user-interrupt) self) 28 | (^super proceedable-condition 29 | initialize self "Resume the interrupted computation.")) 30 | 31 | ;;; This handles the emulator's interface to a user interrupt, which 32 | ;;; consists of pretending that a NOOP instruction failed and passing the 33 | ;;; old value of NARGS to be restored before returning. 34 | 35 | (define (usr-intr n) 36 | (signal user-interrupt) 37 | (set! ((%register 'nargs)) n) 38 | (%return)) 39 | 40 | (set! (nth %argless-tag-trap-table 0) usr-intr) 41 | 42 | ;;; Make this condition land us in the debugger instead of being ignored: 43 | 44 | (set! #*error-handlers 45 | (append! #*error-handlers 46 | (list (cons user-interrupt invoke-debugger)))) 47 | 48 | ;;; eof 49 | -------------------------------------------------------------------------------- /src/world/describe.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Barak A. Pearlmutter&Kevin J. Lang 19 | 20 | ;;; A simple describe facility. 21 | 22 | ;;; You can define your own DESCRIBE methods to shadow this one. 23 | 24 | (define-instance describe operation) 25 | 26 | (add-method (describe (object) x) 27 | (deep-describe x)) 28 | 29 | (add-method (describe (fixnum) x) 30 | (if (negative? x) 31 | (^super object describe x) 32 | (let ((o (object-unhash x))) 33 | (if o 34 | (deep-describe o) 35 | (^super object describe x))))) 36 | 37 | (let ((describe-frame (make operation))) 38 | 39 | (add-method (describe-frame (type ivar-list) self frame obj) 40 | (cond ((eq? self variable-length-mixin) 41 | (format #t "~& from ~A:~%" self) 42 | (dotimes (i (- ((%slot 1) obj) 43 | ((%slot 1) (get-type obj)))) 44 | (format #t " ~D : ~S~%" i (%vref obj i)))) 45 | ((not (null? ivar-list)) 46 | (format #t "~& from ~A:~%" self) 47 | (iterate aux ((vars ivar-list)(fp frame)) 48 | (when vars 49 | (format #t " ~A : ~S~%" (car vars) (contents fp)) 50 | (aux (cdr vars) (%increment-locative fp 1))))))) 51 | 52 | (define (deep-describe x) 53 | (bind ((#*forcible-print-magic #f)) 54 | (let ((ty (get-type x))) 55 | (bind ((#*fancy-references #t)) 56 | (format #t "~&~S is of type ~S.~%" x ty)) 57 | (when (= (%tag x) %pointer-tag) 58 | (let ((loc-x (%set-tag x %locative-tag))) 59 | (iterate aux ((alist (get-bp-alist ty))) 60 | (when alist 61 | (describe-frame (caar alist) 62 | (%increment-locative loc-x (cdar alist)) 63 | x) 64 | (aux (cdr alist)))))))) 65 | x) 66 | 67 | ) 68 | 69 | ;;; eof 70 | -------------------------------------------------------------------------------- /src/world/do.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | (%write-char #\.) 19 | -------------------------------------------------------------------------------- /src/world/dump-stack.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;this function uses a really evil compiler-dependent trick. 21 | 22 | (define (dump-stack arg . rest) 23 | (format #t "~A~%" arg) 24 | (set! rest (+ 1 rest)) 25 | (dump-stack . rest)) 26 | -------------------------------------------------------------------------------- /src/world/em.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | (%write-char #\M) 19 | -------------------------------------------------------------------------------- /src/world/eqv.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (define-constant eqv? 21 | 22 | (add-method ((make (mix-types oc-mixer (list foldable-mixin operation))) 23 | (object) x y) 24 | (eq? x y))) 25 | 26 | ;;; eof 27 | -------------------------------------------------------------------------------- /src/world/error.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Barak A. Pearlmutter and Kevin J. Lang 19 | 20 | ;;; This file defines a simple interface to the error system. Like Common 21 | ;;; Lisp, use ERROR if it's fatal and CERROR if it could be corrected and 22 | ;;; proceded from. 23 | 24 | ;;; This holds how many recursive debuggers we're inside. 25 | (set! #*debug-level 0) 26 | 27 | (define (warning format-string . format-args) 28 | (format standard-error "~&Warning: ") 29 | (format standard-error format-string . format-args)) 30 | 31 | (define (poison . args) 32 | (listify-args (lambda (args) 33 | (error "The poison function was called with args ~S." args)) 34 | . args)) 35 | 36 | ;;; eof 37 | -------------------------------------------------------------------------------- /src/world/error2.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; This is a stopgap error handling system. It defines the following 21 | ;;; macros: 22 | ;;; 23 | ;;; (error-return "Specify a value to be returned from this construct." 24 | ;;; . body) 25 | ;;; 26 | ;;; (error-restart "Specify some new values for these variables." 27 | ;;; ((var1 val1)(var2 val2)) 28 | ;;; . body) 29 | ;;; 30 | ;;; The implementation involves making catch tags and stashing them in a 31 | ;;; data structure bound to a fluid variable. 32 | 33 | (set! #*restart-handlers '()) 34 | 35 | (define-syntax (error-return message . body) 36 | (let ((tag (genvar))) 37 | `(native-catch ,tag 38 | (bind ((#*restart-handlers 39 | (cons (list ,message 40 | (lambda (x) (throw ,tag (and x (car x)))) 41 | 1) 42 | #*restart-handlers))) 43 | ,@body)))) 44 | 45 | ;;; This utility function is used below for rebinding only the supplied vars. 46 | 47 | (define (subst-vals-in old new) 48 | (cond ((null? new) old) 49 | (else (cons (car new) 50 | (subst-vals-in (cdr old) (cdr new)))))) 51 | 52 | (define-syntax (error-restart message variables . body) 53 | (let ((aux (genvar)) 54 | (tag (genvar)) 55 | (tag0 (genvar)) 56 | (messvar (genvar)) 57 | (temps (map (lambda (x) (genvar)) variables))) 58 | `(native-catch ,tag0 59 | (let ((,messvar ,message)) 60 | (iterate ,aux ,variables 61 | (destructure ,temps 62 | (subst-vals-in 63 | (list ,@(map car variables)) 64 | (catch ,tag 65 | (throw 66 | ,tag0 67 | (bind ((#*restart-handlers 68 | (cons (list ,messvar ,tag ,(length variables)) 69 | #*restart-handlers))) 70 | ,@body)))) 71 | (,aux ,@temps))))))) 72 | 73 | (define (show-handlers) 74 | (format #t "~& Active handlers:~%") 75 | (iterate aux ((i 0)(l (reverse #*restart-handlers))) 76 | (when (not (null? l)) 77 | (format #t " ~D: ~A~%" i (caar l)) 78 | (aux (+ i 1) (cdr l))))) 79 | 80 | (define (ret n . args) 81 | (listify-args 82 | (lambda (args) 83 | (let* ((handlers #*restart-handlers) 84 | (nhandlers (length handlers)) 85 | (handler (nth handlers (- nhandlers (1+ n))))) 86 | (destructure (message tag arg-count) handler 87 | (format standard-error "~&Invoking handler \"~A\"~%" message) 88 | (cond ((< arg-count (length args)) 89 | (error "Handler \"~A\" was passed ~D args but takes only ~D.~%" 90 | message (length args) arg-count)) 91 | (else (tag args)))))) 92 | . args)) 93 | 94 | ;;; eof 95 | -------------------------------------------------------------------------------- /src/world/error3.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; This file contains nice macros and functions for doing typical things 21 | ;;; with the error system. 22 | 23 | 24 | ;;; This binds a handler to some class of errors. When such an error 25 | ;;; occurs, an appropriate error object is created and the given handler 26 | ;;; is then applied to it. Invoke-debugger is a useful handler when 27 | ;;; within some other context which is trying to handle a class 28 | ;;; of errors that shouldn't be so handled in a limited dynamic context. 29 | 30 | (define-syntax (bind-error-handler (error-type handler) . body) 31 | `(bind ((#*error-handlers 32 | (cons (cons ,error-type ,handler) 33 | #*error-handlers))) 34 | ,@body)) 35 | 36 | 37 | ;;; This construct has a number of different variations, depending on how 38 | ;;; much stuff you pass in after the error-type, if any. The simplest form 39 | ;;; simply returns #f from the construct if the given type of error occurs. 40 | ;;; In more complex forms, if the error occurs the first operation after 41 | ;;; the error-type is invoked on the error, and if no error occurs 42 | ;;; the other lambda is invoked on the result of the computation. 43 | 44 | ;;; Syntax: (CATCH-ERRORS (error-type [error-lambda [non-error-lambda]]) 45 | ;;; . body) 46 | 47 | (define-syntax (catch-errors (error-type . more-stuff) . body) 48 | (let ((v (genvar))) 49 | (destructure** more-stuff 50 | (() `(native-catch ,v 51 | (bind-error-handler 52 | (,error-type (lambda (err) (throw ,v #f))) 53 | ,@body))) 54 | ((error-lambda) 55 | `(native-catch ,v 56 | (bind-error-handler 57 | (,error-type 58 | (lambda (err) (throw ,v (,error-lambda err)))) 59 | ,@body))) 60 | ((error-lambda noerror-lambda) 61 | `(native-catch ,v 62 | (,noerror-lambda 63 | (bind-error-handler 64 | (,error-type 65 | (lambda (err) 66 | (throw ,v (,error-lambda err)))) 67 | ,@body))))))) 68 | 69 | ;;; eof 70 | -------------------------------------------------------------------------------- /src/world/eval.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (define (eval form locale) 21 | (subeval (expand-groveling locale form) locale)) 22 | 23 | (define (subeval form locale) 24 | (#*top-level-evaluator form locale)) 25 | 26 | (set! #*top-level-evaluator interpreter-eval) 27 | 28 | 29 | (define (hybrid-eval form locale) 30 | ((if (contains-add-method? form) compiler-eval interpreter-eval) 31 | form locale)) 32 | 33 | (let ((warned-yet? #f)) 34 | 35 | (define (compiler-eval form locale) 36 | (unless warned-yet? 37 | (warning "compiler isn't loaded, using interpreter.") 38 | (set! warned-yet? #t)) 39 | (interpreter-eval form locale))) 40 | 41 | 42 | (define (contains-add-method? form) 43 | (and (pair? form) 44 | (not (eq? 'quote (car form))) 45 | (or (eq? '%add-method (car form)) 46 | (contains-add-method? (car form)) ;close enough for 47 | (contains-add-method? (cdr form))))) ;rock and roll. 48 | -------------------------------------------------------------------------------- /src/world/exit.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (let ((exit-aux 21 | (lambda (args) 22 | (destructure (status . format-args) args 23 | (flush standard-error) 24 | (cond ((null? format-args) 25 | (format standard-output "~&Oaklisp stopped itself") 26 | (when (not (= 0 status)) 27 | (format standard-output " (status ~D)" status)) 28 | (format standard-output ".~%")) 29 | (else (apply format standard-output format-args))) 30 | (flush standard-output) 31 | (flush standard-error) 32 | (cond ((= 0 status) ((%halt 0))) 33 | ((= 1 status) ((%halt 1))) 34 | ((= 2 status) ((%halt 2))) 35 | ((= 3 status) ((%halt 3))) 36 | ((= 4 status) ((%halt 4))) 37 | ((= 5 status) ((%halt 5))) 38 | ((= 6 status) ((%halt 6))) 39 | ((= 7 status) ((%halt 7))) 40 | ((= 8 status) ((%halt 8))) 41 | ((= 9 status) ((%halt 9))) 42 | ((= 10 status) ((%halt 10))) 43 | (else 44 | (format standard-output 45 | "(exit status ~D out of range)~%" status) 46 | (flush standard-output) 47 | ((%halt 10)))))))) 48 | 49 | (define (exit . args) 50 | (cond ((= 0 (rest-length args)) 51 | (listify-args exit-aux #*debug-level . args)) 52 | (else 53 | (listify-args exit-aux . args))))) 54 | 55 | ;;; eof 56 | -------------------------------------------------------------------------------- /src/world/export.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;;Copyright (C) 1987 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | (define (export-sharing-cell source destination variable) 21 | (let ((try (variable-here? source variable))) 22 | (if try 23 | (set! (variable-here? destination variable) try) 24 | (warning "~S not found in ~S; can't export.~%" variable source)))) 25 | 26 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /src/world/file-errors.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | 21 | ;;; Define some error types to signal when file system stuff fails. Below, 22 | ;;; fs is used as an abbreviation for file system. 23 | 24 | (define-instance fs-error type '() (list general-error)) 25 | 26 | (define-instance proceedable-fs-error type 27 | '() (list proceedable-error fs-error)) 28 | 29 | (define-instance error-opening type '(name) (list proceedable-fs-error)) 30 | 31 | (define-instance error-opening-read type '() (list error-opening object)) 32 | (define-instance error-opening-write type '() (list error-opening object)) 33 | (define-instance error-opening-append type '() (list error-opening object)) 34 | 35 | (add-method (initialize (error-opening name) self filename) 36 | (set! name filename) 37 | (^super proceedable-fs-error initialize self 38 | (format #f "Supply a file to ~A instead (none to retry \"~A\")." 39 | (what-attempting self) filename))) 40 | 41 | (add-method (report (error-opening name) self stream) 42 | (format stream "Unable to open ~S for ~A access.~%" 43 | name (what-attempting self))) 44 | 45 | ;;; If passed no new filename return the old one. 46 | (add-method (really-invoke-debugger (error-opening name) self) 47 | (or (^super proceedable-fs-error really-invoke-debugger self) 48 | name)) 49 | 50 | (define-instance what-attempting operation) 51 | (add-method (what-attempting (error-opening-read) self) 'read) 52 | (add-method (what-attempting (error-opening-write) self) 'write) 53 | (add-method (what-attempting (error-opening-append) self) 'append) 54 | 55 | (define-instance error-changing-directory 56 | type '(name) (list proceedable-fs-error object)) 57 | 58 | (add-method (initialize (error-changing-directory name) self filename) 59 | (set! name filename) 60 | (^super proceedable-fs-error initialize self 61 | (format #f "Supply a directory to change to (none to retry \"~A\")." 62 | filename))) 63 | 64 | (add-method (report (error-changing-directory name) self stream) 65 | (format stream "Unable to change to directory \"~A\".~%" name)) 66 | 67 | ;;; eof 68 | -------------------------------------------------------------------------------- /src/world/file-io.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1989 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | ;;; Oddly enough, here we do NOT define the OS specific ways to 21 | ;;; manipulate file descriptors. Rather, in this file we do the 22 | ;;; standard sexpr level filesystem interface: READ-FILE and WRITE-FILE, which 23 | ;;; read all the forms out of a file into a list and write a form to a 24 | ;;; file, respectively. 25 | 26 | (define (read-file file) 27 | (with-open-file (s file in) 28 | (read-until the-eof-token #f s))) 29 | 30 | (define (write-file file obj) 31 | (error-restart 32 | (format #f "Try writing ~S again (optionally under another name)." file) 33 | ((file file)) 34 | (with-open-file (s file out ugly) 35 | (bind ((#*print-level #f) 36 | (#*print-length #f) 37 | (#*print-radix 10) 38 | (#*print-escape #t) 39 | (#*symbol-slashification-style 't-compatible) 40 | (#*fraction-display-style 'normal)) 41 | (print obj s)))) 42 | #f) 43 | 44 | (define (dofile file op) 45 | (with-open-file (s file in) 46 | (iterate aux () 47 | (let ((x (read s))) 48 | (unless (eq? x the-eof-token) 49 | (op x) 50 | (aux)))))) 51 | 52 | ;;; eof 53 | -------------------------------------------------------------------------------- /src/world/fluid.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; This file contains code that implements fluid variables. 21 | 22 | (define top-level-fluid-binding-list (list (cons nil nil))) 23 | 24 | 25 | (define get-current-fluid-bindings 26 | (add-method ((make operation)) 27 | (let ((z (or %no-threading (%load-process)))) 28 | (if (eq? z 0) 29 | fluid-binding-list 30 | (fluid-bindings z))))) 31 | 32 | (define set-current-fluid-bindings 33 | (add-method ((make operation) new-binding-list) 34 | (let ((z (or %no-threading (%load-process)))) 35 | (if (eq? z 0) 36 | (set! fluid-binding-list new-binding-list) 37 | (set! (fluid-bindings z) new-binding-list))))) 38 | 39 | (define add-to-current-fluid-bindings 40 | (add-method ((make operation) c-cell) 41 | (let ((z (or %no-threading (%load-process)))) 42 | (if (eq? z 0) 43 | (set! (cdr top-level-fluid-binding-list) 44 | (cons c-cell (cdr top-level-fluid-binding-list))) 45 | (append! (fluid-bindings z) (cons c-cell nil)))))) 46 | 47 | 48 | 49 | ;;; This is to be called at warm boot time: 50 | 51 | (define (revert-fluid-binding-list) 52 | (set! fluid-binding-list top-level-fluid-binding-list)) 53 | ;(define (revert-fluid-binding-list) 54 | ; (set-current-fluid-bindings top-level-fluid-binding-list)) 55 | ;(define (revert-fluid-binding-list) 56 | ; (set-current-fluid-bindings (cons (cons nil nil) nil))) 57 | 58 | ;;; And at cold boot time too, I suppose: 59 | 60 | (revert-fluid-binding-list) 61 | 62 | #| 63 | ;;; This must be delayed until later in the world building process. 64 | (define-syntax (fluid x) 65 | `(%fluid ',x)) 66 | |# 67 | 68 | (define-constant-instance %fluid locatable-operation) 69 | 70 | (add-method (%fluid (symbol) sym) 71 | (iterate aux () 72 | (let ((x (%assq sym (get-current-fluid-bindings)))) 73 | (cond (x => cdr) 74 | (else (cerror 75 | (format #f "Try looking up (FLUID ~S) again." sym) 76 | "(FLUID ~S) not found." sym) 77 | (aux)))))) 78 | 79 | (add-method ((setter %fluid) (symbol) sym val) 80 | (let ((x (%assq sym (get-current-fluid-bindings)))) 81 | (cond (x (set! (cdr x) val)) 82 | (else (add-to-current-fluid-bindings (cons sym val)) 83 | val)))) 84 | 85 | (add-method ((locater %fluid) (symbol) sym) 86 | (iterate aux () 87 | (let ((x (%assq sym (get-current-fluid-bindings)))) 88 | (cond (x (make-locative (cdr x))) 89 | (else 90 | (cerror 91 | (format #f "Try looking up (FLUID ~S) again." sym) 92 | "Locative to (FLUID ~S) not found." sym) 93 | (aux)))))) 94 | 95 | ;;; eof 96 | -------------------------------------------------------------------------------- /src/world/freeze.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;; The locale structure looks like this: 21 | ;; 22 | ;; SYSTEM 23 | ;; / \ 24 | ;; COMPILER SYSTEM-INTERNALS 25 | ;; / \ 26 | ;; SCRATCH COMPILER-INTERNALS 27 | ;; 28 | 29 | ;; System-locale gets filled in from the boot world by patch-locales.oak. 30 | 31 | (set! #*current-locale system-locale) 32 | 33 | (let ((remember-to-freeze (freeze-in-current-locale #f))) 34 | 35 | (define (freeze-in-current-locale variable) 36 | (set! (frozen-here? #*current-locale variable) #t)) 37 | 38 | (dolist (variable remember-to-freeze) 39 | (freeze-in-current-locale variable))) 40 | 41 | ;;; eof 42 | -------------------------------------------------------------------------------- /src/world/gc.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (define-constant %gc 21 | (add-method ((make-open-coded-operation '((gc)) 0 1) 22 | (object)) 23 | (%gc))) 24 | 25 | (define-constant %full-gc 26 | (add-method ((make-open-coded-operation '((full-gc)) 0 1) 27 | (object)) 28 | (%full-gc))) 29 | 30 | ;;; Maybe there should be an interface to the next-newspace-size register 31 | ;;; here. And maybe RECLAIM_FRACTION should be a register with an interface 32 | ;;; here instead of a C compile-time constant. 33 | 34 | ;;; eof 35 | -------------------------------------------------------------------------------- /src/world/has-method.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | ;;; Define the has-method? operation. 21 | 22 | (define (has-method? typ op) 23 | (let ((it (%get-an-ivar operation op 'lambda?))) 24 | (and (not (eq? it 0)) 25 | (or (and it (subtype? typ object)) 26 | (really-has-method? typ op))))) 27 | 28 | 29 | (define-instance really-has-method? operation) 30 | 31 | (add-method (really-has-method? (type supertype-list operation-method-alist) 32 | self op) 33 | (or (%assq op operation-method-alist) 34 | (any? (lambda (typ) (really-has-method? typ op)) 35 | supertype-list))) 36 | 37 | ;;; eof 38 | -------------------------------------------------------------------------------- /src/world/icky-macros.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Barak A. Pearlmutter and Kevin J. Lang 19 | 20 | ;;; The following two things are a hack, but they should speed up string 21 | ;;; access by a lot, and this optimization is anything but premature. 22 | 23 | (define-syntax (%fixnum->character x) 24 | `(%crunch (ash-left ,x 6) 1)) 25 | 26 | (define-syntax (%character->fixnum x) 27 | `(ash-left (%data ,x) -6)) 28 | 29 | ;;; End of icky macros that compile to tense code. 30 | -------------------------------------------------------------------------------- /src/world/kernel0types.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | ;;; This program defines some types in a crude way so that 21 | ;;; we can send messages to everything. 22 | ;;; Most of these these types must be adjusted later in the boot 23 | ;;; process so that their inheritance relationships will be correct. 24 | 25 | (set! ((%slot 0) %code-vector) type) 26 | (set! ((%slot 0) cons-pair) type) 27 | (set! ((%slot 0) string) type) 28 | 29 | 30 | (set! %method (%allocate type 9)) 31 | (set! %closed-environment (%allocate type 9)) 32 | (set! null-type (%allocate type 9)) 33 | (set! fixnum (%allocate type 9)) 34 | (set! locative (%allocate type 9)) 35 | 36 | (set! ((%register 'fixnum-type)) (the-runtime fixnum)) 37 | ;(set! ((%register 'cons-type)) (the-runtime cons-pair)) 38 | (set! ((%register 'loc-type)) (the-runtime locative)) 39 | (set! ((%register 'env-type)) (the-runtime %closed-environment)) 40 | (set! ((%register 'method-type)) (the-runtime %method)) 41 | (set! ((%register 'operation-type)) (the-runtime operation)) 42 | 43 | ;; The MAKE-CLOSED-ENVIRONMENT instruction has been modified to disallow 44 | ;; an argument of 0: 45 | ;(set! %empty-environment (%make-closed-environment)) 46 | (set! %empty-environment (%varlen-allocate %closed-environment 2)) 47 | 48 | (let ((booter ((%register 'boot-code)))) 49 | (set! ((%slot 0) booter) %method) 50 | (set! ((%slot 2) booter) %empty-environment)) 51 | 52 | (set! %sort-of-init (%allocate operation %simple-operation-length)) 53 | (set! ((%slot 1) %sort-of-init) 0) 54 | (_add-method (%sort-of-init (type supertype-list type-bp-alist 55 | operation-method-alist) 56 | self) 57 | (set! supertype-list (list object)) 58 | (set! type-bp-alist `((,self . 1))) 59 | (set! operation-method-alist nil)) 60 | 61 | (%sort-of-init %code-vector) 62 | (%sort-of-init cons-pair) 63 | (%sort-of-init string) 64 | (%sort-of-init %method) 65 | (%sort-of-init %closed-environment) 66 | (%sort-of-init null-type) 67 | (%sort-of-init fixnum) 68 | (%sort-of-init locative) 69 | 70 | (set! ((%slot 0) '()) null-type) 71 | -------------------------------------------------------------------------------- /src/world/kernel1-freeze.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | (let ((remember-to-freeze '())) 21 | 22 | (define (freeze-in-current-locale variable) 23 | (if variable 24 | (push remember-to-freeze variable) 25 | remember-to-freeze))) 26 | 27 | ;; Now freeze everything that should have been frozen in the files preceding 28 | ;; this that couldn't be because this stuff wasn't defined yet: 29 | 30 | (dolist (v '(operation object make type %varlen-make initialize nil t 31 | %method fixnum cons-pair locative %closed-environment)) 32 | (freeze-in-current-locale v)) 33 | 34 | ;;; eof 35 | -------------------------------------------------------------------------------- /src/world/kernel1-funs.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;;;;;;;;;some functions defined here for expediency;;;;;;;;;; 21 | 22 | (set! subtype? (%allocate operation %simple-operation-length)) 23 | (set! %length (%allocate operation %simple-operation-length)) 24 | (set! %memq (%allocate operation %simple-operation-length)) 25 | (set! %append (%allocate operation %simple-operation-length)) 26 | 27 | (set! ((%slot 1) subtype?) 0) 28 | (set! ((%slot 1) %length) 0) 29 | (set! ((%slot 1) %memq) 0) 30 | (set! ((%slot 1) %append) 0) 31 | 32 | 33 | ;;; SUBTYPE? code goes here because of some load dependencies. 34 | 35 | (add-method (subtype? (type type-bp-alist) self potential-super) 36 | (not (null? (%assq potential-super type-bp-alist)))) 37 | 38 | (add-method (%length (object) l) 39 | (iterate aux ((l l) (n 0)) 40 | (if (null? l) n (aux (cdr l) (+ n 1))))) 41 | 42 | (add-method (%memq (object) ob l) 43 | (cond ((null? l) '()) 44 | ((eq? ob (car l)) l) 45 | (else (%memq ob (cdr l))))) 46 | 47 | (add-method (%append (object) a b) 48 | (cond ((null? a) b) 49 | ((null? b) a) 50 | (else 51 | (cons (car a) (%append (cdr a) b))))) 52 | 53 | 54 | 55 | 56 | 57 | 58 | #| 59 | (add-method (subtype? (type supertype-list) self potential-super) 60 | (or (eq? self potential-super) 61 | (iterate aux ((l supertype-list)) 62 | (cond ((null? l) nil) 63 | (else 64 | (let ((cdrl (cdr l))) 65 | (cond ((null? cdrl) (subtype? (car l) potential-super)) 66 | ((subtype? (car l) potential-super) t) 67 | (else (aux cdrl))))))))) 68 | |# 69 | -------------------------------------------------------------------------------- /src/world/kernel1-inittypes.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Kevin J. Lang and Barak A. Pearlmutter 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;;; time to back patch some types 22 | 23 | (set! variable-length-mixin (make type '() '())) 24 | 25 | (initialize %closed-environment '() (list variable-length-mixin object)) 26 | (%your-top-wired %closed-environment) ;this provides no protection 27 | 28 | (initialize %code-vector '(ivar-map) (list variable-length-mixin object)) 29 | (%your-top-wired %code-vector) ;this provides no protection 30 | 31 | (initialize %method '(the-code the-environment) (list object)) 32 | (add-method (initialize (%method the-code the-environment) self c e) 33 | (set! the-code c) 34 | (set! the-environment e) 35 | self) 36 | -------------------------------------------------------------------------------- /src/world/kernel1-make.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;;; Copyright (C) 1987 Kevin J. Lang and Barak A. Pearlmutter 19 | 20 | ;;; how to make things 21 | 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | ;;; Make MAKE 24 | 25 | (set! make (%allocate operation %simple-operation-length)) 26 | (set! %varlen-make (%allocate operation %simple-operation-length)) 27 | 28 | (set! ((%slot 1) make) 0) 29 | (set! ((%slot 1) %varlen-make) 0) 30 | 31 | 32 | (set! variable-length-mixin 'not-really-varlen-mixin) 33 | 34 | (add-method (make (type instance-length) self . args) 35 | (if (subtype? self variable-length-mixin) 36 | (%varlen-make self . args) 37 | (let ((new-guy (%allocate self instance-length))) 38 | (initialize new-guy . args)))) 39 | 40 | ;;; This %varlen-allocate instruction exists to close a tiny GC 41 | ;;; window. 42 | 43 | (add-method (%varlen-make (type instance-length) self ncells . args) 44 | (let* ((guylen (+ instance-length ncells)) 45 | (new-guy (%varlen-allocate self guylen))) 46 | (initialize new-guy ncells . args))) 47 | 48 | 49 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 50 | ;;; Make INITIALIZE 51 | 52 | (set! initialize (%allocate operation %simple-operation-length)) 53 | (set! ((%slot 1) initialize) 0) 54 | 55 | 56 | ;;; This took (self . more) and check if more was empty; no more. 57 | 58 | (add-method (initialize (object) self) 59 | self) 60 | 61 | ;;; eof 62 | -------------------------------------------------------------------------------- /src/world/kernel1-segments.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | (define-instance stack-segment type 21 | '(previous-segment) (list variable-length-mixin object)) 22 | 23 | (set! ((%register 'segment-type)) (the-runtime stack-segment)) 24 | 25 | ;;; eof 26 | -------------------------------------------------------------------------------- /src/world/logops.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (define (xor a b) 21 | (if a 22 | (not b) 23 | b)) 24 | 25 | (define (and* . args) 26 | (cond ((= (rest-length args) 0) 27 | t) 28 | (else (and*aux . args)))) 29 | 30 | (define (and*aux arg . args) 31 | (cond (arg (if (= (rest-length args) 0) 32 | arg 33 | (and*aux . args))) 34 | (else (consume-args nil . args)))) 35 | 36 | (define (or* . args) 37 | (cond ((= (rest-length args) 0) 38 | nil) 39 | (else (or*aux . args)))) 40 | 41 | (define (or*aux arg . args) 42 | (cond (arg (consume-args arg . args)) 43 | (else (if (= (rest-length args) 0) 44 | nil 45 | (or*aux . args))))) 46 | 47 | -------------------------------------------------------------------------------- /src/world/make-locales.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;; currently, the locale structure looks like this: 21 | ;; 22 | ;; SYSTEM . . . OAKLISP 23 | ;; / \ 24 | ;; COMPILER USER 25 | ;; 26 | ;; 27 | ;; 28 | 29 | ;; system-locale gets filled in from the boot world by patch-locales.oak. 30 | ;; oaklisp-locale will be filled with stuff exported from system-locale. 31 | 32 | (define-instance system-locale locale '()) 33 | (define-instance compiler-locale locale (list system-locale)) 34 | 35 | (define-instance oaklisp-locale locale '()) 36 | (define-instance user-locale locale (list oaklisp-locale)) 37 | 38 | ;;; eof 39 | -------------------------------------------------------------------------------- /src/world/make-makefile.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1992 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | (define (make-makefile name) 21 | (with-open-file (outfile name out) 22 | 23 | (let* ((aller (lambda (x) 24 | (format outfile " ~A.oa" (downcase (#^string x))))) 25 | (aller1 (lambda (x) (if (not (memq x between-files)) (aller x))))) 26 | 27 | (format outfile "# This included makefile data is automatically~%") 28 | (format outfile "# generated by make-makefile.oak, and should not~%") 29 | (format outfile "# normally be edited by hand. It can be regenerated~%") 30 | (format outfile "# with 'make Makefile-vars'.~%") 31 | (format outfile "~%") 32 | 33 | (format outfile "COLDFILES =") 34 | (for-each aller between-files) 35 | (for-each aller1 all-the-layers) 36 | (format outfile "~%") 37 | 38 | (format outfile "COLDFILESNONGEN =") 39 | (for-each aller between-files) 40 | (for-each aller1 (remove all-the-layers 'system-version)) 41 | (format outfile "~%") 42 | 43 | (format outfile "COLDFILESD =") 44 | (for-each aller all-the-layers) 45 | (format outfile "~%") 46 | 47 | (format outfile "MISCFILES =") 48 | (for-each aller misc-files) 49 | (format outfile "~%") 50 | 51 | (format outfile "COMPFILES =") 52 | (for-each aller compiler-files) 53 | (format outfile "~%") 54 | 55 | (format outfile "RNRSFILES =") 56 | (for-each aller scheme-files) 57 | (format outfile "~%") 58 | 59 | (format outfile "TOOLFILES = tool.oa~%") 60 | (format outfile "FILESFILES = files.oa~%") 61 | (format outfile "MAKEFILES = make-makefile.oa~%") 62 | (format outfile "~%") 63 | (format outfile "# These are gravy. The first two are our standard~%") 64 | (format outfile "# benchmarks. The others are neat.~%") 65 | (format outfile "~%") 66 | (format outfile "GRAVY = tak.oak compile-bench.oak prolog.oak prolog-examples.oak multiproc-tests.oak random.oak~%") 67 | (format outfile "~%") 68 | 69 | (format outfile "# Special rules for the compiler's source~%") 70 | (format outfile "~%") 71 | 72 | (for-each (lambda (f) 73 | (format outfile "~a.oa " (downcase (#^string f)))) 74 | compiler-files) 75 | (format outfile ": OAKLOCALE=--locale compiler-locale~%"))) 76 | 77 | name) 78 | -------------------------------------------------------------------------------- /src/world/math.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | 21 | (define prime-list 22 | (labels (((prime? n) 23 | (iterate aux ((l prime-list)) 24 | (let* ((i (car l)) 25 | (n/i (quotient n i))) 26 | (cond ((< n/i i) #t) 27 | ((= (* i n/i) n) #f) 28 | (else (aux (cdr l))))))) 29 | 30 | ((primes-list n) 31 | (if (prime? n) 32 | (lcons n (primes-list (+ 1 n))) 33 | (primes-list (+ 1 n))))) 34 | 35 | (lcons 2 (primes-list 3)))) 36 | 37 | 38 | (define (factor n) 39 | (iterate step ((left n) (factors '()) (tries prime-list)) 40 | (let* ((try (car tries)) 41 | (try-square (* try try))) 42 | (cond ((= 1 left) factors) 43 | ((zero? (modulo left try)) 44 | (step (quotient left try) (cons try factors) tries)) 45 | ((> try-square left) 46 | (cons left factors)) 47 | (else 48 | (step left factors (cdr tries))))))) 49 | 50 | 51 | ;;; eof 52 | -------------------------------------------------------------------------------- /src/world/mix-types.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;; 22 | ;; Define mixin management tools. 23 | ;; 24 | 25 | (define-instance mixin-manager type '(type-alist) (list object)) 26 | 27 | (add-method (initialize (mixin-manager type-alist) self) 28 | (set! type-alist '()) 29 | self) 30 | 31 | (define-instance mix-types operation) 32 | 33 | (add-method (mix-types (mixin-manager type-alist) self types) 34 | ;; Run through the list looking for what we want. 35 | (iterate aux ((l type-alist)) 36 | (if (null? l) 37 | ;; not on list, make it. 38 | (let ((newtype (make type '() types))) 39 | (set! type-alist (cons (cons types newtype) type-alist)) 40 | newtype) 41 | 42 | ;; We want to write test (EQUAL? TYPES (CAAR L)) here, but 43 | ;; EQUAL? doesn't work yet so the comparison is done inline, 44 | ;; element by element. 45 | 46 | (labels ((non-equal-exit (lambda () (aux (cdr l))))) 47 | 48 | (iterate loop ((x types) (y (caar l))) 49 | (cond ((null? x) 50 | (if (null? y) 51 | ;; They are equal, return the right type: 52 | (cdar l) 53 | (non-equal-exit))) 54 | ((or (null? y) 55 | (not (eq? (car x) (car y)))) 56 | (non-equal-exit)) 57 | (else (loop (cdr x) (cdr y))))))))) 58 | 59 | ;;; eof 60 | -------------------------------------------------------------------------------- /src/world/multi-em.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;; 19 | ;; The functions in this souce file assist in the creation and management 20 | ;; of heavyweight threads. 21 | ;; 22 | 23 | 24 | ;; 25 | ;; Creates a new heavyweight thread 26 | ;; This method takes one argument, the function to be run in the 27 | ;; virtual machine running on the new heavyweight thread. 28 | ;; The given function should loop forever. If it returns, a seg-fault 29 | ;; will occur (it's not a bug, it's a feature). 30 | ;; This function returns t if the thread is created, nil if it could 31 | ;; not be created. 32 | ;; 33 | (define-constant %make-heavyweight-thread 34 | (add-method ((make-open-coded-operation '((make-heavyweight-thread)) 1 1) 35 | (object) target) 36 | (%make-heavyweight-thread target))) 37 | 38 | ;; 39 | ;; Returns the variable stored in the "process" register. Each virtual 40 | ;; machine has its own process register. It is used with the process 41 | ;; scheduler (see multiproc.oak) to keep track of what process is currently 42 | ;; being executed on this heavyweight thread. 43 | ;; 44 | (define-constant %load-process 45 | (add-method ((make-open-coded-operation '((load-reg process)) 0 1) 46 | (object)) 47 | (%load-process))) 48 | 49 | ;; 50 | ;; Stores the variable in the "process" register. The compliment of 51 | ;; %load-process. 52 | ;; 53 | (define-constant %store-process 54 | (add-method ((make-open-coded-operation '((store-reg process)) 1 1) 55 | (object) value) 56 | (%store-process value))) 57 | 58 | ;; An atomic operation that tests the value in a locative and sets it 59 | ;; to NEW if the value is currently OLD. A boolean is returned to 60 | ;; indicate success or failure. 61 | 62 | (define-constant %test-and-set-locative 63 | (add-method ((make-open-coded-operation '((test-and-set-locative)) 3 1) 64 | (locative) loc old new) 65 | (%test-and-set-locative loc old new))) 66 | -------------------------------------------------------------------------------- /src/world/multi-off.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; This is to guard all usage of thread-related functions so they don't 19 | ;;; get used during the cold boot process. In particular: fluids. 20 | 21 | ;;; Set this to FALSE when threading is turned on. 22 | 23 | (define %no-threading 0) 24 | -------------------------------------------------------------------------------- /src/world/multiproc-tests.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | 19 | ;; regression tests start here... 20 | 21 | (process-id (current-process)) 22 | (%make-heavyweight-thread start-busy-work) 23 | 24 | (define x (make mutex)) 25 | (acquire-mutex x) 26 | (release-mutex x) 27 | 28 | (define y (delay (+ 1 2))) 29 | (define z (future (+ 1 2))) 30 | 31 | (define (test-fn) 32 | (while t (format t "~s~%" (process-id (current-process))))) 33 | (process-run-fn test-fn nil) 34 | (process-run-fn test-fn nil) 35 | (process-run-fn test-fn nil) 36 | (test-fn) 37 | 38 | (set! #*thing 'adf) 39 | #*thing ; Should return symbol ADF 40 | 41 | (bind ((#*hello "hello")) #*hello) ; Returns "hello" 42 | #*hello ; Should error 43 | 44 | (bind ((#*hello "hello")) (set! #*world "world")) 45 | #*world ; Returns "world" 46 | #*hello ; Should error 47 | 48 | (set! #*forcible-print-magic #f) 49 | 50 | 51 | ;;; TO DO 52 | 53 | ;;; register for # instructions until alarms ? 54 | ;;; at least make interval modifiable 55 | 56 | ;;; change C thread maker so malloc'ed stuff doesn't get into oaklisp space 57 | 58 | ;;; rationalize process descriptor table C vs Oaklisp interface 59 | 60 | ;;; process priorities 61 | 62 | ;;; make threads extra "level" in build process. Prior to that being 63 | ;;; loaded, NO THREAD STUFF AT ALL. 64 | 65 | ;;; ability to build emulator without thread support 66 | 67 | ;;; race conditions (symbol tables, hash tables, add-method) 68 | 69 | ;;; performance 70 | 71 | ;;; make sure throwing out of thread gets an error 72 | 73 | 74 | ;;; completely rewrite allocation subsystem 75 | -------------------------------------------------------------------------------- /src/world/nargs.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | ;;; Some entry points. 21 | 22 | (let ((bad-nargs 23 | (lambda (stuff) 24 | (destructure (extra-okay requested op . args) stuff 25 | (signal (if extra-okay nargs-gte-error nargs-exact-error) 26 | op args requested))))) 27 | 28 | (define (incorrect-nargs requested op . args) 29 | (listify-args bad-nargs #f requested op . args)) 30 | 31 | (define (incorrect-nargs-gte minimum-requested op . args) 32 | (listify-args bad-nargs #t minimum-requested op . args))) 33 | 34 | (set! (nth %arged-tag-trap-table 24) incorrect-nargs) 35 | (set! (nth %arged-tag-trap-table 25) incorrect-nargs-gte) 36 | 37 | ;;; eof 38 | -------------------------------------------------------------------------------- /src/world/obsolese.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Kevin J. Lang and Barak A. Pearlmutter 19 | 20 | ;;; A macro for declaring an obsolescent synonym for a newly renamed operation. 21 | 22 | ;;; BUGS: I doubt this works for settable operations. Perhaps this should 23 | ;;; operate at the locale level, so it could catch any reference. 24 | 25 | (define-syntax (define-old-name old new) 26 | `(define ,old 27 | (let ((already-warned #f)) 28 | (lambda ( . args ) 29 | (unless already-warned 30 | (set! already-warned t) 31 | (format standard-error 32 | ,(format #f 33 | "~~&Warning: ~A is obsolete, use ~A instead.~~%" 34 | old new)) 35 | (set! ,old ,new)) 36 | (,new . args))))) 37 | 38 | ;;; eof 39 | -------------------------------------------------------------------------------- /src/world/op-error.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;;; Copyright (C) 1986 Kevin J. Lang and Barak A. Pearlmutter 19 | 20 | ;;; This entry point strips off the arg field that we don't care about 21 | ;;; that the emulator stuck on because funcall is an arged 22 | ;;; instruction. 23 | 24 | (define (no-handler-for-operation n . args) 25 | (listify-args failed-funcall . args)) 26 | 27 | ;;; Leave autoforcing turned off until the facility actually comes up. 28 | 29 | (define forcible-magic #f) 30 | 31 | ;;; This function actually does the work. 32 | 33 | (define (failed-funcall args) 34 | (destructure (op . args) args 35 | (cond 36 | ;; It would be nice if the user level error system could 37 | ;; handle this: 38 | ((and forcible-magic 39 | ;; IS-A? not used because it might force the promise, and 40 | ;; then the promse would end up not getting forced. Clear? 41 | (subtype? (get-type op) forcible)) 42 | (apply (force op) args)) 43 | ((not (is-a? op operation)) 44 | (signal not-an-operation op args)) 45 | ((and (not (null? args)) 46 | (is-a? op locatable-operation) 47 | (has-method? (get-type (car args)) (locater op))) 48 | (when monitor-for-bruce 49 | (%write-char #\%)) 50 | (contents (apply (locater op) args))) 51 | ;; In an ideal world this would be handled at user level: 52 | ((and forcible-magic (not (null? args)) 53 | ;; IS-A? not used because it might force the promise, and 54 | ;; then the promse would end up not getting forced. Clear? 55 | (subtype? (get-type (car args)) forcible)) 56 | (apply op (force (car args)) (cdr args))) 57 | (else 58 | (signal operation-not-found op args))))) 59 | 60 | (set! (nth %arged-tag-trap-table 21) no-handler-for-operation) 61 | (set! (nth %arged-tag-trap-table 22) no-handler-for-operation) 62 | 63 | ;;; This is in direct analogy with the above. 64 | 65 | (define (no-^super-handler n . args) 66 | (listify-args failed-^super . args)) 67 | 68 | (define (failed-^super args) 69 | (destructure (the-type op . args) args 70 | (signal ^super-not-found the-type op args))) 71 | 72 | (set! (nth %arged-tag-trap-table 33) no-^super-handler) 73 | (set! (nth %arged-tag-trap-table 34) no-^super-handler) 74 | 75 | ;;; eof 76 | -------------------------------------------------------------------------------- /src/world/ops.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;;; Copyright (C) 1987 Kevin J. Lang and Barak A. Pearlmutter 19 | 20 | ;;; make some operations before their definition files 21 | 22 | (define-instance print operation) 23 | (define-instance fill! operation) 24 | (define-instance equal? operation) 25 | (define-instance reverse operation) 26 | (define-instance reverse! operation) 27 | (define-instance copy operation) 28 | (define-instance remove operation) 29 | (define-instance remove-if operation) 30 | 31 | (define-instance subseq operation) 32 | (define-instance subsequence? operation) 33 | 34 | (define-constant-instance length settable-operation) 35 | (define-constant-instance nth locatable-operation) 36 | (define-constant-instance present? locatable-operation) 37 | 38 | ;early error messages shouldn't die. 39 | (add-method (print (object) self stream) 40 | (write-char stream #\&)) 41 | 42 | ;;; eof 43 | -------------------------------------------------------------------------------- /src/world/patch-locales.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | 21 | (define (patch-locales) 22 | (iterate go ((varloc %%varloc)(symloc %%symloc)(count 0)) 23 | (print-noise #\&) 24 | (when (< count %%nvars) 25 | (set! (variable-here? system-locale (%set-tag symloc %pointer-tag)) 26 | varloc) 27 | (go (%increment-locative varloc 1) 28 | (%increment-locative symloc %%symsize) 29 | (+ 1 count))))) 30 | 31 | (patch-locales) 32 | 33 | 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /src/world/patch-symbols.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (iterate go ((curloc %%symloc)(count 0)) 21 | (print-noise #\~) 22 | (when (< count %%nsyms) 23 | (let ((this-one (%set-tag curloc %pointer-tag))) 24 | (intern this-one) 25 | (go (%increment-locative curloc %%symsize) (+ 1 count))))) 26 | 27 | ;;; eof 28 | -------------------------------------------------------------------------------- /src/world/patch0symbols.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (iterate go ((curloc %%symloc)(count 0)) 21 | (when (< count %%nsyms) 22 | (let ((this-one (%crunch (%data curloc) %pointer-tag))) 23 | (set! ((%slot 0) this-one) symbol) 24 | (go (%increment-locative curloc %%symsize) (+ 1 count))))) 25 | 26 | ;;; eof 27 | -------------------------------------------------------------------------------- /src/world/pl.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | (%write-char #\+) 19 | -------------------------------------------------------------------------------- /src/world/predicates.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; The following can fail for things that don't inherit from OBJECT, 21 | ;;; or that do it in the wrong order. These anomalous conditions should 22 | ;;; probably be detected at type creation time, and cause the type to be 23 | ;;; uninstantiable. 24 | 25 | (define (type-pred typ) 26 | (let ((op (make operation))) 27 | 28 | ;; Force delays and check 'em again. 29 | (add-method (op (forcible) self) (op (force self))) 30 | 31 | ;; Yes for instances of TYP. 32 | (add-method (op (typ) self) #t) 33 | 34 | ;; No is the default. 35 | (add-method (op (object) self) #f) 36 | 37 | op)) 38 | 39 | (define (inverse-type-pred typ) 40 | (let ((op (make operation))) 41 | 42 | ;; Force delays and check 'em again. 43 | (add-method (op (forcible) self) (op (force self))) 44 | 45 | ;; No for instances of TYP. 46 | (add-method (op (typ) self) #f) 47 | 48 | ;; Yes is the default. 49 | (add-method (op (object) self) #t) 50 | 51 | op)) 52 | 53 | (define number? (type-pred number)) 54 | (define integer? (type-pred integer)) 55 | (define fixnum? (type-pred fixnum)) 56 | 57 | (define symbol? (type-pred symbol)) 58 | (define string? (type-pred string)) 59 | (define char? (type-pred character)) 60 | 61 | (define pair? (type-pred pair)) 62 | (define list? (type-pred list-type)) 63 | (define atom? (inverse-type-pred pair)) 64 | 65 | (define procedure? (type-pred operation)) 66 | (define vector? (type-pred simple-vector)) 67 | 68 | ;null? is defined in subprimitive.oak. 69 | -------------------------------------------------------------------------------- /src/world/print-integer.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; How to print integers. Lets try to be fast out there... 21 | 22 | 23 | (define (digit->char x) 24 | (%fixnum->character 25 | (+ x (if (< x 10) 26 | (#^number #\0) 27 | (- (#^number #\A) 10))))) 28 | 29 | 30 | (define (print-place x place stream) 31 | (let ((q (quotient x place)) 32 | (r (remainder x place))) 33 | (write-char stream (digit->char q)) 34 | r)) 35 | 36 | 37 | (add-method (print (integer) self stream) 38 | (cond ((negative? self) 39 | (write-char stream #\-) (print (- self) stream) self) 40 | ((zero? self) 41 | (write-char stream #\0) self) 42 | (else 43 | (let ((base #*print-radix)) 44 | ;; Successive division; push onto list 45 | (iterate aux ((digits '()) (rem self)) 46 | (cond ((zero? rem) 47 | (dolist (d digits self) 48 | (write-char stream (digit->char d)))) 49 | (else 50 | (aux (cons (remainder rem base) digits) 51 | (quotient rem base))))))))) 52 | 53 | 54 | (add-method (print (fixnum) self stream) 55 | (cond ((negative? self) 56 | (write-char stream #\-) (print (- self) stream) self) 57 | 58 | ((zero? self) 59 | (write-char stream #\0) self) 60 | 61 | ((= #*print-radix 10) 62 | 63 | ;; Special case base 10. 64 | ;; Have to add another digit here is FIXNUMS get bigger, and take one 65 | ;; off if they get smaller. Because this goes in the cold world, 66 | ;; none of these can be bignums, as the world builder doesn't know 67 | ;; how to format them in memory. 68 | 69 | (labels ((d9 (lambda (q) (d8 (print-place q 100000000 stream)))) 70 | (d8 (lambda (q) (d7 (print-place q 10000000 stream)))) 71 | (d7 (lambda (q) (d6 (print-place q 1000000 stream)))) 72 | (d6 (lambda (q) (d5 (print-place q 100000 stream)))) 73 | (d5 (lambda (q) (d4 (print-place q 10000 stream)))) 74 | (d4 (lambda (q) (d3 (print-place q 1000 stream)))) 75 | (d3 (lambda (q) (d2 (print-place q 100 stream)))) 76 | (d2 (lambda (q) (d1 (print-place q 10 stream)))) 77 | (d1 (lambda (q) (write-char stream (digit->char q)) self))) 78 | 79 | (cond ((< self 10) (d1 self)) 80 | ((< self 100) (d2 self)) 81 | ((< self 1000) (d3 self)) 82 | ((< self 10000) (d4 self)) 83 | ((< self 100000) (d5 self)) 84 | ((< self 1000000) (d6 self)) 85 | ((< self 10000000) (d7 self)) 86 | ((< self 100000000) (d8 self)) 87 | (else (d9 self))))) 88 | 89 | (else (^super integer print self stream)))) 90 | 91 | ;;; eof 92 | -------------------------------------------------------------------------------- /src/world/print-noise.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (let ((count 0)) 21 | (define (print-noise char) 22 | (if (= count 0) 23 | (%write-char #\nl)) 24 | (%write-char char) 25 | (set! count (modulo (+ 1 count) 50)))) 26 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /src/world/print.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; Print methods for some standard system types that print in a simple way. 21 | 22 | (define (define-simple-print-method typ name) 23 | (add-method (print (typ) self stream) 24 | (format stream "#<~A ~!>" name self) 25 | self)) 26 | 27 | 28 | (define-simple-print-method object "Object") 29 | (define-simple-print-method type "Type") 30 | (define-simple-print-method coercable-type "Coercable") 31 | (define-simple-print-method operation "Op") 32 | (define-simple-print-method settable-operation "SettableOp") 33 | (define-simple-print-method locatable-operation "LocatableOp") 34 | (define-simple-print-method variable-length-mixin "VLmixin") 35 | 36 | (add-method (print (locative) self stream) 37 | ;(format stream "#" self (contents self)) 38 | (format stream "#" self)) 39 | 40 | ;;; eof 41 | -------------------------------------------------------------------------------- /src/world/random.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 2002, Barak A. Pearlmutter 19 | ;;; Modified from code by Troy Ross 20 | 21 | (define random-device "/dev/urandom") 22 | 23 | (define random-device-stream #f) 24 | 25 | (define random256 26 | (lambda () 27 | (unless random-device-stream 28 | (set! random-device-stream (open-input-file random-device))) 29 | (#^number (read-char random-device-stream)))) 30 | 31 | ;;; (define random259200 32 | ;;; (let ((rand-seed 444)) 33 | ;;; (lambda () 34 | ;;; (set! rand-seed (modulo (+ 54773 (* 7141 rand-seed)) 259200)) 35 | ;;; rand-seed))) 36 | -------------------------------------------------------------------------------- /src/world/rounding.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; The rounding stuff from R3RS. 21 | 22 | (define-instance floor operation) 23 | (define-instance ceiling operation) 24 | (define-instance truncate operation) 25 | (define-instance round operation) 26 | 27 | 28 | (dolist (op (list floor ceiling truncate round)) 29 | (add-method (op (integer) x) x)) 30 | 31 | (add-method (floor (fraction the-numerator the-denominator) x) 32 | (quotientm the-numerator the-denominator)) 33 | 34 | (add-method (ceiling (fraction the-numerator the-denominator) x) 35 | (+ (quotientm the-numerator the-denominator) 1)) 36 | 37 | (add-method (truncate (fraction the-numerator the-denominator) x) 38 | (quotient the-numerator the-denominator)) 39 | 40 | ;;; This rounds to the nearest integer, breaking ties by rounding to even: 41 | (add-method (round (fraction the-numerator the-denominator) x) 42 | (let ((f (quotientm the-numerator the-denominator))) 43 | (cond ((= the-denominator 2) 44 | ;; round to even: 45 | (if (even? f) f (+ 1 f))) 46 | (else 47 | (let ((m (modulo the-numerator the-denominator))) 48 | (if (< (+ m m) the-denominator) 49 | f (+ 1 f))))))) 50 | 51 | ;;; eof 52 | -------------------------------------------------------------------------------- /src/world/scheme-macros.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | ;;; The following macro definitions are different from those in 21 | ;;; system-locale in a non-upward-compatible way. These definitions 22 | ;;; should NOT be loaded into system-locale. They may be compiled 23 | ;;; there, though. 24 | 25 | 26 | 27 | ;;; Because all forms that take implicit bodies ultimately put a BLOCK 28 | ;;; around these bodies, the above also makes ADD-METHOD, and hence 29 | ;;; LAMBDA, as well as stuff like COND clause bodies, get the horrible 30 | ;;; MIT Scheme define-capturing semantics. 31 | 32 | (define-syntax (block . body) `(mit-block . ,body)) 33 | 34 | ;;; That committee must have Algol on the brain. 35 | 36 | (define-syntax (begin . body) `(block . ,body)) 37 | 38 | 39 | 40 | ;;; Here, we make the dotted arglist syntax do the R3RS thing, getting 41 | ;;; bound to a list of things. We do this by hacking ADD-METHOD to 42 | ;;; wrap a LABELS if appropriate. 43 | 44 | (define-syntax (add-method (op . stuff) . body) 45 | (cond ((improper-list? stuff) 46 | => 47 | (lambda (improper-part) 48 | (let ((proper-part (make-proper stuff)) 49 | (auxvar (genvar))) 50 | 51 | (cond ((and (not (null? proper-part)) 52 | (list? (car proper-part)) 53 | (not (null? (cdr (car proper-part))))) 54 | ;; There are ivars, have to close over them. 55 | `(native-add-method (,op ,(car proper-part) 56 | . ,improper-part) 57 | (let ((,auxvar 58 | (lambda (,improper-part) 59 | (destructure 60 | ,(cdr stuff) ,improper-part 61 | ,@body)))) 62 | (listify-args ,auxvar . ,improper-part)))) 63 | (else 64 | ;; No ivars, make external lambda 65 | 66 | `(let ((,auxvar 67 | (lambda (,improper-part) 68 | (destructure 69 | ,(if (and (not (null? proper-part)) 70 | (list? (car proper-part))) 71 | ;; clause 72 | (cdr stuff) 73 | stuff) ,improper-part 74 | ,@body)))) 75 | (native-add-method 76 | (,op ,@(if (and (not (null? proper-part)) 77 | (list? (car proper-part))) 78 | (list (car proper-part)) 79 | (list)) 80 | . ,improper-part) 81 | (listify-args 82 | ,auxvar . ,improper-part)))))))) 83 | 84 | (else `(native-add-method (,op . ,stuff) . ,body)))) 85 | 86 | ;;; eof 87 | -------------------------------------------------------------------------------- /src/world/sort.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | 21 | ;;; A generic sorting facility. 22 | 23 | (define-instance sort operation) 24 | (define-instance sort! operation) 25 | 26 | (add-method (sort (sequence) v <=?) 27 | (sort! (copy v) <=?)) 28 | 29 | (add-method (sort! (sequence) v <=?) 30 | ;; This does a stupid bubble sort. Should be fixed. 31 | (let ((len (length v))) 32 | ;;(vsort v (make simple-vector len) 0 0 len) 33 | (when (> len 0) 34 | (dotimes (i (- len 1)) 35 | (iterate aux ((j (+ i 1))) 36 | (when (< j len) 37 | (when (<=? (nth v j) (nth v i)) 38 | (swap (nth v i) (nth v j))) 39 | (aux (+ j 1)))))) 40 | v)) 41 | 42 | 43 | 44 | 45 | ;;; Practice run for the Indiana Parenthesis Sweepstake Open: 46 | 47 | (labels ([sort-aux 48 | ;; Sort the first LEN elements of L. MERGER is used to 49 | ;; merge sublists. 50 | (lambda (l len <=? merger) 51 | (cond [(< len 2) l] 52 | [else 53 | (let* ([len/2 (quotient len 2)] 54 | [len/2b (- len len/2)] 55 | [lb (tail l len/2)]) 56 | (merger (sort-aux l len/2 <=? merger) len/2 57 | (sort-aux lb len/2b <=? merger) len/2b 58 | <=?))]))] 59 | [merge!-aux 60 | ;; Destructively merges the first LENA guys of LA with the 61 | ;; first LENB guys of LB. 62 | (lambda (la lena lb lenb <=?) 63 | (cond [(zero? lena) lb] 64 | [(zero? lenb) la] 65 | [(not (<=? (car lb) (car la))) 66 | (set! (cdr la) 67 | (merge!-aux (cdr la) (- lena 1) 68 | lb lenb <=?)) 69 | la] 70 | [else 71 | (set! (cdr lb) 72 | (merge!-aux la lena 73 | (cdr lb) (- lenb 1) <=?)) 74 | lb]))] 75 | [merge-aux 76 | ;; Merge the first LENA guys of LA with the first LENB guys of LB. 77 | (lambda (la lena lb lenb <=?) 78 | (cond [(zero? lena) lb] 79 | [(zero? lenb) la] 80 | [else 81 | (let ([a (car la)] 82 | [b (car lb)]) 83 | (if (<=? b a) 84 | (cons b 85 | (merge-aux la lena 86 | (cdr lb) (- lenb 1) 87 | <=?)) 88 | (cons a 89 | (merge-aux (cdr la) (- lena 1) 90 | lb lenb <=?))))]))]) 91 | 92 | (add-method (sort! (list-type) l <=?) 93 | (let* ([len (length l)] 94 | [l (sort-aux l len <=? merge!-aux)]) 95 | (unless (zero? len) 96 | (set! (cdr (tail l (- len 1))) nil)) 97 | l)) 98 | 99 | (add-method (sort (list-type) l <=?) 100 | (let* ([len (length l)] 101 | [l (sort-aux l (length l) <=? merge-aux)]) 102 | (head l len)))) 103 | 104 | ;;; eof 105 | -------------------------------------------------------------------------------- /src/world/st.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | (%write-char #\*) 19 | -------------------------------------------------------------------------------- /src/world/string-stream.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | ;;; Magic streams that don't really do i/o, but save or get their 21 | ;;; stuff from strings. Used mostly for (FORMAT NIL ...) and some 22 | ;;; Common Lisp like things. 23 | 24 | (define-instance string-output-stream 25 | type '(accumulated) (list output-stream object)) 26 | 27 | (add-method (initialize (string-output-stream accumulated) self) 28 | (set! accumulated '()) 29 | self) 30 | 31 | (add-method (write-char (string-output-stream accumulated) self char) 32 | (set! accumulated (cons char accumulated)) 33 | char) 34 | 35 | (add-method (#^string (string-output-stream accumulated) self) 36 | (#^string (reverse accumulated))) 37 | 38 | ;;; Calling this a STRING-INPUT-STREAM is a misnomer; actually, it can get 39 | ;;; its input from any sequence. 40 | 41 | (define-instance string-input-stream 42 | type '(the-string index len) (list input-stream stream object)) 43 | 44 | (add-method (initialize (string-input-stream the-string index len) self stuff) 45 | (set! the-string stuff) 46 | (set! index 0) 47 | (set! len (length the-string)) 48 | (^super input-stream initialize self)) 49 | 50 | (add-method (really-read-char (string-input-stream the-string index len) self) 51 | (if (= index len) 52 | the-eof-token 53 | (block0 (nth the-string index) 54 | (set! index (+ index 1))))) 55 | 56 | ;;; eof 57 | -------------------------------------------------------------------------------- /src/world/subtypes.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Barak A. Pearlmutter & Kevin J. Lang 19 | 20 | ;;; Set up the immediate types. 21 | 22 | ;;; There are 6 bits of immediate subtype tag: 23 | 24 | (define-instance subtype-table simple-vector 64) 25 | 26 | (define-instance illegal-immediate type '() (list object)) 27 | 28 | (add-method (print (illegal-immediate) self stream) 29 | (format stream "#" 30 | (ash-left (%data self) -6) 31 | (bit-and (%data self) #x3F) 32 | (%tag self))) 33 | 34 | (dotimes (i 64) 35 | (set! (nth subtype-table i) illegal-immediate)) 36 | 37 | (define (setup-subtype-table) 38 | (set! ((%register 'subtype-table)) subtype-table)) 39 | 40 | (setup-subtype-table) 41 | 42 | ;;; Now for characters 43 | 44 | (define-constant-instance character 45 | coercable-type '() (list self-evaluatory-mixin object)) 46 | 47 | (set! #^character 48 | (make (mix-types oc-mixer (list foldable-mixin settable-operation)))) 49 | 50 | (add-method (#^character (character) x) x) 51 | 52 | (set! (nth subtype-table 0) character) 53 | 54 | (define-instance graphic? operation) 55 | 56 | (add-method (graphic? (character) self) 57 | (let ((cn (#^number self))) 58 | (and (<= (#^number #\!) cn) 59 | (<= cn (#^number #\~))))) 60 | 61 | (add-method (print (character) self stream) 62 | (cond (#*print-escape 63 | (write-char stream #\#) 64 | (write-char stream #\\) 65 | (cond ((and (not (graphic? self)) 66 | (#^symbol self)) 67 | => (lambda (p) (print p stream))) 68 | (else 69 | (write-char stream self)))) 70 | (else 71 | (write-char stream self)))) 72 | 73 | (add-method (#^character (fixnum) x) 74 | (%crunch (ash-left x 6) 1)) 75 | 76 | (add-method (#^number (character) x) 77 | (ash-left (%data x) -6)) 78 | 79 | (add-method (= (character) x y) 80 | (eq? x y)) 81 | 82 | (add-method (< (character) x y) 83 | (if (char? y) 84 | (< (%character->fixnum x) 85 | (%character->fixnum y)) 86 | (error "Incompatible types: (< ~S ~S)." x y))) 87 | 88 | ;;; eof 89 | -------------------------------------------------------------------------------- /src/world/super.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; Define the ^super operation, which is basically written in 21 | ;;; microcode. One day ^super should be open coded everywhere. 22 | 23 | (define (^super the-type the-op self . args) 24 | ;; Hack NARGS and tail off to the ^SUPER opcode. 25 | ;; This leaves an unnecessary (RETURN) in the object file. 26 | (set! ((%register 'nargs)) (- ((%register 'nargs)) 2)) 27 | (%^super-tail the-type the-op self)) 28 | 29 | ;;; eof 30 | -------------------------------------------------------------------------------- /src/world/system-version.oak.in: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (define system-version "@PACKAGE_STRING@") 21 | -------------------------------------------------------------------------------- /src/world/tak.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (define (tak x y z) 21 | (cond ((not (< y x)) z) 22 | (else (tak (tak (- x 1) y z) 23 | (tak (- y 1) z x) 24 | (tak (- z 1) x y))))) 25 | 26 | #| 27 | ;;; hacked for siod 28 | (define (tak x y z) 29 | (if (< y x) 30 | (tak (tak (- x 1) y z) 31 | (tak (- y 1) z x) 32 | (tak (- z 1) x y)) 33 | z)) 34 | |# 35 | 36 | ;;; This tests the effect of block compilation: 37 | (define (tak2 x y z) 38 | (iterate tak ((x x)(y y)(z z)) 39 | (cond ((not (< y x)) z) 40 | (else (tak (tak2 (- x 1) y z) 41 | (tak2 (- y 1) z x) 42 | (tak2 (- z 1) x y)))))) 43 | 44 | (define (macnine x) 45 | (if (> x 100) 46 | (- x 10) 47 | (macnine (macnine (+ x 11))))) 48 | 49 | 50 | -------------------------------------------------------------------------------- /src/world/time.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (define (*time f n) 21 | (let ((before (get-time))) 22 | (dotimes (i n (/ (- (get-time) before) n)) 23 | (f)))) 24 | 25 | (define-syntax (time (n) . body) 26 | `(*time (lambda () . ,body) ,n)) 27 | 28 | ;;; eof 29 | -------------------------------------------------------------------------------- /src/world/top-level.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (set! top-level 21 | (lambda () 22 | (format #t "~&Welcome to ~A~%" system-version) 23 | (read-eval-print-loop))) 24 | -------------------------------------------------------------------------------- /src/world/truth.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; Define the canonical truth value, that has a print syntax #T. The 21 | ;;; world builder has it made already, so we patch the reference. 22 | 23 | (define-instance truths type '() (list self-evaluatory-mixin object)) 24 | 25 | (set! ((%slot 0) t) truths) 26 | 27 | (define-constant else t) 28 | 29 | (add-method (print (truths) self stream) 30 | (format stream "#T")) 31 | 32 | ;;; eof 33 | -------------------------------------------------------------------------------- /src/world/undefined.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; This file creates undefined values. INITIALIZE and PRINT methods 21 | ;;; are provided for them, but you shouldn't be able to do much else 22 | ;;; to them. 23 | 24 | ;;; When making an undefined value pass one argument, a description of 25 | ;;; where the undefined value came from. 26 | 27 | (define-instance undefined type '(origin) (list object)) 28 | 29 | (add-method (initialize (undefined origin) self the-origin) 30 | (set! origin the-origin) 31 | self) 32 | 33 | (add-method (print (undefined origin) self stream) 34 | (format stream "#" origin self)) 35 | 36 | ;;; Some canonical undefined values: 37 | 38 | (define-instance variable-undefined-value undefined 'variable) 39 | (define-instance ivar-undefined-value undefined 'ivar) 40 | (define-instance if-undefined-value undefined 'if) 41 | (define-instance cond-undefined-value undefined 'cond) 42 | (define-instance when-undefined-value undefined 'when) 43 | (define-instance unless-undefined-value undefined 'unless) 44 | (define-instance while-undefined-value undefined 'while) 45 | 46 | (define-instance generic-undefined-value undefined 'generic) 47 | 48 | ;;; 49 | 50 | (define (make-undefined-variable-value sym) 51 | (make undefined (append "variable " (#^string sym)))) 52 | 53 | ;;; 54 | 55 | (define (setup-undefined-ivar) 56 | (set! ((%register 'uninitialized)) ivar-undefined-value) 57 | nil) 58 | 59 | (setup-undefined-ivar) 60 | 61 | ;;; Defered until warm.oak: 62 | ;;(add-warm-boot-action setup-undefined-ivar) 63 | 64 | ;;; eof 65 | -------------------------------------------------------------------------------- /src/world/vector-type.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | ;;; The abstract vector type: 21 | 22 | (define-instance vector-type coercable-type 23 | '() (list self-evaluatory-mixin sequence)) 24 | 25 | (add-method (print (vector-type) self stream) 26 | (cond ((and #*print-level (= #*print-level 0)) 27 | (write-char stream #\#)) 28 | (else (write-string "#(" stream) 29 | (let ((nmi (- (length self) 1))) 30 | (bind ((#*print-level (and #*print-level (- #*print-level 1)))) 31 | (iterate step ((i 0) (l #*print-length)) 32 | (cond ((and l (= l 0)) 33 | (write-string "..." stream)) 34 | ((<= i nmi) 35 | (print (nth self i) stream) 36 | (cond ((< i nmi) 37 | (write-char stream #\space) 38 | (step (+ i 1) (and l (- l 1)))))))))) 39 | (write-char stream #\))))) 40 | 41 | ;;; eof 42 | -------------------------------------------------------------------------------- /src/world/warm.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (define warm-boot-actions '()) 21 | 22 | (define (warm-boot) 23 | (%write-char #\W) 24 | (%write-char #\a) 25 | (%write-char #\r) 26 | (%write-char #\m) 27 | (%write-char #\space) 28 | (%write-char #\b) 29 | (%write-char #\o) 30 | (%write-char #\o) 31 | (%write-char #\t) 32 | (%write-char #\i) 33 | (%write-char #\n) 34 | (%write-char #\g) 35 | (%write-char #\space) 36 | (dolist (op warm-boot-actions) 37 | (op) 38 | (%write-char #\.))) 39 | 40 | 41 | (define (add-warm-boot-action op) 42 | (set! warm-boot-actions (append! warm-boot-actions (list op))) 43 | op) 44 | 45 | 46 | ;;; Due to load order constraints, some things go here rather than in 47 | ;;; the files they are defined in. 48 | 49 | ;;; from UNDEFINED: 50 | (add-warm-boot-action setup-undefined-ivar) 51 | 52 | ;;; from TAG-TRAP: 53 | (add-warm-boot-action setup-tag-traps) 54 | 55 | ;;; from SUBTYPES: 56 | (add-warm-boot-action setup-subtype-table) 57 | 58 | ;;; from FLUID: 59 | (add-warm-boot-action revert-fluid-binding-list) 60 | 61 | ;;; eof 62 | -------------------------------------------------------------------------------- /src/world/weak.oak: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Oaklisp. 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | ;;; 8 | ;;; This program is distributed in the hope that it will be useful, 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;;; GNU General Public License for more details. 12 | ;;; 13 | ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html 14 | ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, 15 | ;;; Boston, MA 02111-1307, USA 16 | 17 | 18 | ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter 19 | 20 | (define-constant object-hash 21 | (add-method ((make-open-coded-operation '((object-hash)) 1 1) 22 | (object) x) 23 | (object-hash x))) 24 | 25 | (define-constant object-unhash 26 | (add-method ((make-open-coded-operation '((object-unhash)) 1 1) 27 | (fixnum) x) 28 | (object-unhash x))) 29 | 30 | ;;; eof 31 | --------------------------------------------------------------------------------