oaklisp-1.3.3.orig/0002775000175000000620000000000011036654362013071 5ustar barakstaffoaklisp-1.3.3.orig/src/0002775000175000000620000000000011036654362013660 5ustar barakstaffoaklisp-1.3.3.orig/src/lib/0002775000175000000620000000000011036654362014426 5ustar barakstaffoaklisp-1.3.3.orig/src/CREDITS0000664000175000000620000000307210752410706014674 0ustar barakstaff This is a credits-file of people that have contributed to the Oaklisp project. It is formatted to allow easy grepping and beautification by scripts. The fields are: name (N), email (E), web-address (W), PGP key ID and fingerprint (P), description (D), and snail-mail address (S). ---------- N: Kevin J. Lang E: langk@yahoo-inc.com D: much of language design. much of system design. D: much of lang & lim manuals. D: bytecode compiler. list manipulation. much of emulator. world i/o. D: much of runtime system. bignum division. much of bignums. S: Yahoo! Research N: Barak A. Pearlmutter E: barak+oaklisp@cs.nuim.ie W: http://www.bcl.hamilton.ie/~barak/ P: pub 1024D/FEC23FB2 2000-08-21 P: Key fingerprint = 3755 EE8A 783F 3493 A8FF 2C8F 2F3E 069E FEC2 3FB2 D: much of language design. much of system design. D: much of lang & lim manuals. D: most of bytecode emulator. call/cc. weak pointers. gc. strings. D: much of runtime system. I/O. much of bignums. rationals. vectors. D: interpreter. hash tables. symbols. locales. macros. delays. S: Hamilton Institute S: National University of Ireland Maynooth S: Co. Kildare S: Ireland N: Alexander Stuebinger E: stuebi@acm.org W: http://www.uni-mainz.de/~stuebi D: emulator mods 93 -> 99: optimizations, ANSI-ification, etc. S: Burgunderstrasse 3 S: 76829 Landau S: Germany N: Joerg-Cyril Hoehle E: hoehle@tzd.telekom.de D: helped alex spec out his emulator mods D: perceptive bug-sniffer and system tester: found make-lambda %full-gc bug D: ported SLIB and GAMBIT-benchmarks to Oaklisp D: scheme-locale mods oaklisp-1.3.3.orig/src/misc/0002775000175000000620000000000011036654362014613 5ustar barakstaffoaklisp-1.3.3.orig/src/misc/unit-testing.oak0000664000175000000620000002533510752632263017747 0ustar barakstaff;;; FILE "unit-testing.oak" ;;; IMPLEMENTS Unit Testing for Oaklisp ;;; AUTHOR Ken Dickey ;;; COPYRIGHT (c) 2004 by Kenneth A Dickey; All rights reserved. ;;; This is free software. Permission to use, copy, modify and ;;; distribute this software for non-profit purpose is granted without ;;; fee. It is provided "as is" without express or implied warranty. ;;; The author disclaims all warranties with regard to this software. ;;; In no event shall the author be liable for any damages. ;;;USAGE SYNOPSIS ;; Tests are first created and added to a global UNIT-TESTS "database". ;; Tests are arranged by UNIT-NAME (just a symbol naming a set of tests). ;; ;; SPECIAL FORMS: ;; (ADD-TEST unit-name expected-result form =? . message) ;; ;; (ADD-EQ-TEST unit-name expected-result form . message) ;; => (add-test unit-name expected-result form EQ? . message) ;; ;; (ADD-EQUAL-TEST unit-name expected-result form . message) ;; => (add-test unit-name expected-result form EQUAL? . message) ;; ;; (ENSURE-EXCEPTION-RAISED unit exception-type form . message) ;; -> test that the form signals a (subtype of) exception-type ;; ;; All forms are "thunkified" by being wrapped in zero argument lambdas. ;; Internal usage is: (=? expected (thunk)) ;; ;; ;; TESTING OPERATIONS: ;; (RUN-ALL-TESTS unit-tests) => Run all suites of tests. ;; ;; (RUN-TESTS-FOR unit-tests 'whatever) => Run tests for unit named WHATEVER. ;; ;; (REMOVE-TESTS-FOR unit-tests 'whatever) => Remove tests for unit named WHATEVER. ;; ..handy before rereading a test defining file. ;; ;; If (VERBOSE? unit-tests) is false, only failures and exceptions are ;; reported, else successful tests are reported as well. ;; The default value is #f. Settable. ;; ;; If (BREAK-ON-ERROR? unit-tests) is true, errors and exceptions break ;; into the debugger, otherwise failures are just reported. ;; The default value is #f. Settable. ;; ;; Tests are typically written as separate files containing set-up & tear-down code. ;; @@QUESTION: Add optional set-up and tear-down forms to unit test suites? ;; ;; Note Also: ;; (RUN-TEST verbose-p break-on-error-p) ;; Run a single -- typically only used for debugging tests. ;; If no error, don't report unless VERBOSE-P ;; If error or exception, break into debugger if BREAK-ON-ERROR-P, else continue ;; ;; (make unit-name expected thunk =? . message) ;; @@QUESTION: Should take an output-stream? Currently all output ;; goes to (current-output-port). ;;;====================================================================== ;; @@FIXME: TABLE-WALK belongs in hash-table.oak ;; Should define WALK for SEQUENCE as well... (define-instance table-walk operation) ;; proc takes 2 args: (lambda (key val) ...) (add-method (table-walk (generic-hash-table table count size) self proc) (dotimes (index size) (let ((chain (nth table index))) (for-each (lambda (bucket) (proc (car bucket) (cdr bucket))) chain)))) (add-method (table-walk (eq-hash-table table count size) self proc) (dotimes (index size) (let ((chain (nth table index))) (for-each (lambda (bucket) (proc (car bucket) (cdr bucket))) chain)))) ;;;====================================================================== ;; @@FIXME: Is a reasnable naming convention for type FOO? (define-instance type '(verbose-p break-on-error-p) (list eq-hash-table)) ; really a symbol-table (add-method (initialize ( verbose-p break-on-error-p) self) (set! verbose-p #f) (set! break-on-error-p #f) (^super eq-hash-table initialize self)) ;; @@FIXME: This should not be required. Why not simply inherited? (add-method ((setter table-entry) () self key value) (^super eq-hash-table (setter table-entry) self key value)) (define-instance verbose? settable-operation) (define-instance break-on-error? settable-operation) (add-method (verbose? ( verbose-p) self) verbose-p) (add-method ((setter verbose?) ( verbose-p) self bool) (set! verbose-p bool)) (add-method (break-on-error? ( break-on-error-p) self) break-on-error-p) (add-method ((setter break-on-error?) ( break-on-error-p) self bool) (set! break-on-error-p bool)) (define-instance add-unit-test operation) (add-method (add-unit-test () self unit test-case) (set! (table-entry self unit) (cond ((present? self unit) => (lambda (bucket) (cons test-case (cdr bucket)))) (else (list test-case)))) test-case) (define-instance remove-tests-for operation) ;; @@FIXME: no way to remove table entries ?!? (add-method (remove-tests-for () self unit) (set! (table-entry self unit) #f)) (define-instance tests-for operation) (add-method (tests-for () self unit) (table-entry self unit)) (define-constant unit-tests (make )) (define-instance type '(expected thunk compare? message) (list object)) (add-method (initialize ( expected thunk compare? message) self expected-result the-thunk comparison-op? msg) (set! expected expected-result) (set! thunk the-thunk) (set! compare? comparison-op?) (set! message msg) self) (define-syntax (add-test unit expect form equivalent? . message) (let ((msg (if (pair? message) (car message) ""))) `(add-unit-test unit-tests ,unit (make ,expect (lambda () ,form) ,equivalent? ,msg) ))) (define-syntax (add-eq-test unit expect form . message) `(add-test ,unit ,expect ,form eq? . ,message)) (define-syntax (add-equal-test unit expect form . message) `(add-test ,unit ,expect ,form equal? . ,message)) (define-syntax (ensure-exception-raised unit exception-type form . message) (let ((msg (if (pair? message) (car message) ""))) `(add-unit-test unit-tests ,unit (make ,exception-type (lambda () ,form) ,msg) ))) (define-instance type '() (list )) (add-method (initialize () self exception-type thunk message) (unless (subtype? exception-type condition) (error "An requires an exception type: ~a" exception-type)) (^super initialize self exception-type thunk subtype? message) self) (define-instance run-test operation) (define-instance run-all-tests operation) (define-instance run-tests-for operation) ;; Run a ;; If no error, don't report unless VERBOSE-P ;; If error or exception, break into debugger if BREAK-ON-ERROR-P, else continue (add-method (run-test ( expected thunk compare? message) self verbose-p break-on-error-p) (let* ((caught-exception #f) (actual (bind-error-handler (general-error ;; catch every type of error (lambda (err-obj) (set! caught-exception err-obj) (format #t "~&*** EXCEPTION: ~a ~a" err-obj message) (describe err-obj) #f)) (thunk))) ) (cond (caught-exception => (lambda (err-obj) (if break-on-error-p (invoke-debugger err-obj) err-obj)) ;; return err-obj if not breaking ) ((compare? actual expected) (if verbose-p (format #t "~&PASSED: Expected: ~a Got: ~a ~a" expected actual message) #t) ;; compare => #t ) (else ((if break-on-error-p error warning) "~&*** FAILED: Expected ~a Got ~a ~a" expected actual message))))) (add-method (run-tests-for ( verbose-p break-on-error-p) self unit) (let ((unit-tests (tests-for self unit))) (if unit-tests (for-each (lambda (test) (run-test test verbose-p break-on-error-p)) (reverse unit-tests)) ((if break-on-error-p error warning) "~&HUH? No tests found for ~A" unit)))) (add-method (run-all-tests ( verbose-p break-on-error-p) self) (table-walk self (lambda (unit tests) (if tests (block (format #t "~&===>Starting Tests for ~a" unit) (for-each (lambda (test) (run-test test verbose-p break-on-error-p)) (reverse tests)) (format #t "~&===> Completed Tests for ~a~&" unit) ) ((if break-on-error-p error warning) "~&HUH? No tests found for ~A" unit))))) (add-method (run-test () self verbose-p break-on-error-p) ;; helper required for access to internals (%run-exception-test self verbose-p break-on-error-p)) (define-instance %run-exception-test operation) (add-method (%run-exception-test ( expected thunk compare? message) self verbose-p break-on-error-p) (unless (subtype? (get-type self)) (error "EXCEPTION TEST INVOKED ON NON-EXECEPTION: ~a" self)) (let* ((caught-exception #f) (actual (bind-error-handler (general-error ;; catch every type of error (lambda (err-obj) (set! caught-exception err-obj) err-obj)) (thunk))) ) (cond ((compare? (get-type actual) expected) (if verbose-p (format #t "~&PASSED: Expected: ~a Got: ~a of type ~a ~a" expected actual (get-type actual) message) #t) ;; compare => #t ) (caught-exception => (lambda (err-obj) (format #t "~&*** UNEXPECTED EXCEPTION: got ~a of type ~a expected ~a: ~a" err-obj (get-type err-obj) expected message) (describe err-obj) (if break-on-error-p (invoke-debugger err-obj) err-obj)) ;; return err-obj if not breaking ) (else ((if break-on-error-p error warning) "~&*** FAILED: Expected exception of type ~a Got ~a ~a" expected actual message))))) ;;; unit-testing.oak ends here oaklisp-1.3.3.orig/src/misc/testing-tests.oak0000664000175000000620000000127310752632263020125 0ustar barakstaff;;; From: Ken Kickey ;; (require 'unit-testing) ;; (load "unit-testing.oak") (add-eq-test 'one #t (= 1 1) "equal") (add-eq-test 'one #f (< 2 1) "less") (add-eq-test 'one 'foo (intern "FOO") "eq?") ;; interning case is UPPER (add-equal-test 'one "FOO" ((coercer string) 'foo) "equal?") (add-test 'one 37 (+ 36 1) = "addition") (add-test 'two 54 (max 32 1 54 7 23 7 21) = "max") (add-test 'two 'yes (if (> 2 1) 'yes 'no) eq? "if") ;;(add-test 'two 'error-failure (if (> 2 1) 'yes 'no) eq? "if failure") (ensure-exception-raised 'two generic-fatal-error (/ 7 0) "zero divisor exception") ;;(set! (verbose? unit-tests) #t) ;;(run-all-tests unit-tests) ;; EOF ;; oaklisp-1.3.3.orig/src/misc/README0000664000175000000620000000005110752632272015465 0ustar barakstaffMiscellaneous material: contributed etc. oaklisp-1.3.3.orig/src/misc/uniq.oak0000664000175000000620000000040710752632613016261 0ustar barakstaff(define (uniq lis) (do ((alist '() (let ((x (car lis))) (cond ((assoc x alist) => (lambda (p) (set! (cdr p) (+ (cdr p) 1)) alist)) (else (cons (cons x 1) alist))))) (lis lis (cdr lis))) ((null? lis) alist))) oaklisp-1.3.3.orig/src/Makefile0000664000175000000620000000154707725515165015334 0ustar barakstaff# This file is part of Oaklisp. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html # or from the Free Software Foundation, 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA # This value of prefix will usually be overridden prefix=/usr/local .PHONY: all install clean CPPFLAGS=-DFAST all install clean: $(MAKE) -C emulator $@ $(MAKE) -C world $@ oaklisp-1.3.3.orig/src/world/0002775000175000000620000000000011036654364015011 5ustar barakstaffoaklisp-1.3.3.orig/src/world/macros1.oak0000664000175000000620000001700507725515165017060 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang and Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; macros (first chunk) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-syntax (comment . x) ''comment) (define-syntax (let* clauses . body) (if (null? clauses) `(block ,@body) `(let (,(car clauses)) (let* ,(cdr clauses) ,@body)))) (define-syntax define (lambda (form) (destructure** form ;; This clause is for when you go (DEFINE (fluid FOO) 'BAR). ((#t ('fluid var) val) `(set! ,@(cdr form))) ((#t ('fluid var) . #t) (error "Malformed expression ~S." form)) ((#t (var . arglist) . rhstuff) `(set! ,var (lambda ,arglist ,@rhstuff))) ((#t var val) `((setter contents) (make-locative ,var) ,val))))) ; When compiling a file (using compile-file or load-oak-file), ; macro expansion occurs in a sub-locale that is augmented with ; the local syntax of that file, and so ^Vcurrent-locale is temporarily ; rebound to the sub-locale. It is bound to the actual current locale ; during the load phase. ; ; When evaluation occurs as the result of an ordinary call to eval, ; like at the behest of the read-eval-print-loop, this split does not ; occur, so the following three forms are equivalent. (define-syntax (define-syntax sym def) (cond ((pair? sym) (let ((v (genvar))) `(define-syntax ,(car sym) (lambda (,v) (destructure* (#t . ,(cdr sym)) ,v ,def))))) (else ;; Load time: `(set! (macro-here? #*current-locale ',sym) ,def)))) (define-syntax (local-syntax sym def) (cond ((pair? sym) (let ((v (genvar))) `(local-syntax ,(car sym) (lambda (,v) (destructure* (#t ,@(cdr sym)) ,v ,def))))) (else ;; Compile time: (set! (macro-here? #*current-locale sym) (eval def #*current-locale)) ''local-syntax))) (define-syntax (define-local-syntax sym def) (cond ((pair? sym) (let ((v (genvar))) `(define-local-syntax ,(car sym) (lambda (,v) (destructure* (#t ,@(cdr sym)) ,v ,def))))) (else ;; Compile time: (set! (macro-here? #*current-locale sym) (eval def #*current-locale)) ;; Load time: `(set! (macro-here? #*current-locale ',sym) ,def)))) ;;; (define-syntax (define-instance loc typ . args) (let ((t1 (genvar)) (t2 (genvar))) `(let ((,t1 (make-locative ,loc)) (,t2 ,typ)) (if (eq? (get-type (contents ,t1)) ,t2) (contents ,t1) (set! (contents ,t1) (make ,t2 ,@args)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Parallel assignment. Similar to the ZetaLisp form with the ;;; analagous name. For example, (pset (a b) (b c) (c a)) is a ;;; typical use, as is (pset ( (car x) (cdr x) ) ( (cdr x) (car x) )). ;;; The tricky cases are like (pset (a 6) ((car a) 5)). ;;; ;;; Maybe this should be optimized to not make a locative when the ;;; location is a simple variable. But not for global variables, ;;; which is hard. (define-syntax (pset . clauses) (let ((locvars (map genvar/1 clauses)) (valvars (map genvar/1 clauses))) (when (any? (map null? (map cddr clauses))) (error "Malformed PSET clause within ~S." `(pset ,@clauses))) `((lambda ,locvars ((lambda ,valvars ,@(map (lambda (locvar valvar) `(set! (contents ,locvar) ,valvar)) locvars valvars)) ,@(map cadr clauses))) ,@(map (lambda (clause) `(make-locative ,(car clause))) clauses)))) ;;; DOTIMES, just like in Common Lisp (define-syntax (dotimes (var limit . exit-body) . body) (let ((exit-form (and exit-body (destructure* (a) exit-body a))) (v-limit (genvar)) (v-label (genvar))) `(let ((,v-limit ,limit)) (labels (( (,v-label ,var) (cond ((< ,var ,v-limit) ,@body (,v-label (+ ,var 1))) (else ,exit-form)))) (,v-label 0))))) ;;; DO, just like in Common Lisp and R3RS. (define-syntax (do clauses (test . exit-body) . body) (let ((clauses (map (lambda (c) (destructure** c ((var init) `(,var ,init ,var)) ((var init iter) c) (otherwise (error "Malformed DO clause ~S." c)))) clauses)) (aux (genvar))) `(iterate ,aux ,(map list (map car clauses) (map cadr clauses)) (cond (,test ,@exit-body) (else ,@body (,aux ,@(map caddr clauses))))))) (define-syntax (when test . body) `(if ,test (block ,@body) when-undefined-value)) (define-syntax (unless test . body) `(if (not ,test) (block ,@body) unless-undefined-value)) (define-syntax (while test . body) (let ((v (genvar))) `(iterate ,v () (if ,test (block ,@body (,v)) while-undefined-value)))) (define-syntax (select-type selector . clauses) (let ((tv (genvar))) `(let ((,tv (get-type ,selector))) (cond ,@(map (lambda (clause) (destructure** clause (('otherwise . body) `(else ,@body)) ((types . body) `((or ,@(map (lambda (ty) `(subtype? ,tv ,ty)) types)) ,@body)))) clauses))))) (define-syntax (fselect-type selector . clauses) (labels (((aux normal-clauses otherwise-clause v expr) (let ((tv (genvar)) (lab (genvar))) `(iterate ,lab ((,v ,expr)) (let ((,tv (get-type ,v))) (cond ,@(map (lambda (clause) (destructure* (types . body) clause `((or ,@(map (lambda (ty) `(subtype? ,tv ,ty)) types)) ,@body))) normal-clauses) ;; Check if the thing we got is forcible; if so ;; force it and restart the case. ((subtype? ,tv forcible) (,lab (force ,v))) ,@(if otherwise-clause (destructure* ('otherwise . body) otherwise-clause `((else ,@body))) '()))))))) (labels (((aux2 v expr) (if (null? clauses) (aux clauses #f v expr) (let ((lc (last clauses))) (if (eq? (car lc) 'otherwise) (aux (subseq clauses 0 (- (length clauses) 1)) lc v expr) (aux clauses #f v expr)))))) (if (symbol? selector) (aux2 selector selector) (destructure* (v expr) selector (aux2 v expr)))))) (define-syntax (eselect-type selector . clauses) `(select-type ,selector ,@clauses (otherwise (error "Inappropriate type.~%")))) (define-syntax (efselect-type selector . clauses) `(fselect-type ,selector ,@clauses (otherwise (error "Inappropriate type.~%")))) (define-syntax (case key . clauses) (let ((keyvar (genvar))) `(let ((,keyvar ,key)) (cond ,@(map (lambda (clause) (destructure** clause (('else . body) clause) (('otherwise . body) clause) ((things . body) `((or ,@(map (lambda (th) ;; Some things can be compared with ;; EQ? while others require EQV?. `(,(if (or (fixnum? th) (not (number? th))) 'eq? 'eqv?) ',th ,keyvar)) things)) ,@body)))) clauses))))) ;;; eof oaklisp-1.3.3.orig/src/world/undefined.oak0000664000175000000620000000414307725515165017453 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter ;;; This file creates undefined values. INITIALIZE and PRINT methods ;;; are provided for them, but you shouldn't be able to do much else ;;; to them. ;;; When making an undefined value pass one argument, a description of ;;; where the undefined value came from. (define-instance undefined type '(origin) (list object)) (add-method (initialize (undefined origin) self the-origin) (set! origin the-origin) self) (add-method (print (undefined origin) self stream) (format stream "#" origin self)) ;;; Some canonical undefined values: (define-instance variable-undefined-value undefined 'variable) (define-instance ivar-undefined-value undefined 'ivar) (define-instance if-undefined-value undefined 'if) (define-instance cond-undefined-value undefined 'cond) (define-instance when-undefined-value undefined 'when) (define-instance unless-undefined-value undefined 'unless) (define-instance while-undefined-value undefined 'while) (define-instance generic-undefined-value undefined 'generic) ;;; (define (make-undefined-variable-value sym) (make undefined (append "variable " (#^string sym)))) ;;; (define (setup-undefined-ivar) (set! ((%register 'uninitialized)) ivar-undefined-value) nil) (setup-undefined-ivar) ;;; Defered until warm.oak: ;;(add-warm-boot-action setup-undefined-ivar) ;;; eof oaklisp-1.3.3.orig/src/world/subtypes.oak0000664000175000000620000000460607725515165017374 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Barak A. Pearlmutter & Kevin J. Lang ;;; Set up the immediate types. ;;; There are 6 bits of immediate subtype tag: (define-instance subtype-table simple-vector 64) (define-instance illegal-immediate type '() (list object)) (add-method (print (illegal-immediate) self stream) (format stream "#" (ash-left (%data self) -6) (bit-and (%data self) #x3F) (%tag self))) (dotimes (i 64) (set! (nth subtype-table i) illegal-immediate)) (define (setup-subtype-table) (set! ((%register 'subtype-table)) subtype-table)) (setup-subtype-table) ;;; Now for characters (define-constant-instance character coercable-type '() (list self-evaluatory-mixin object)) (set! #^character (make (mix-types oc-mixer (list foldable-mixin settable-operation)))) (add-method (#^character (character) x) x) (set! (nth subtype-table 0) character) (define-instance graphic? operation) (add-method (graphic? (character) self) (let ((cn (#^number self))) (and (<= (#^number #\!) cn) (<= cn (#^number #\~))))) (add-method (print (character) self stream) (cond (#*print-escape (write-char stream #\#) (write-char stream #\\) (cond ((and (not (graphic? self)) (#^symbol self)) => (lambda (p) (print p stream))) (else (write-char stream self)))) (else (write-char stream self)))) (add-method (#^character (fixnum) x) (%crunch (ash-left x 6) 1)) (add-method (#^number (character) x) (ash-left (%data x) -6)) (add-method (= (character) x y) (eq? x y)) (add-method (< (character) x y) (if (char? y) (< (%character->fixnum x) (%character->fixnum y)) (error "Incompatible types: (< ~S ~S)." x y))) ;;; eof oaklisp-1.3.3.orig/src/world/patch-symbols.oak0000664000175000000620000000200007725515165020265 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter (iterate go ((curloc %%symloc)(count 0)) (print-noise #\~) (when (< count %%nsyms) (let ((this-one (%set-tag curloc %pointer-tag))) (intern this-one) (go (%increment-locative curloc %%symsize) (+ 1 count))))) ;;; eof oaklisp-1.3.3.orig/src/world/time.oak0000664000175000000620000000171507725515165016452 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter (define (*time f n) (let ((before (get-time))) (dotimes (i n (/ (- (get-time) before) n)) (f)))) (define-syntax (time (n) . body) `(*time (lambda () . ,body) ,n)) ;;; eof oaklisp-1.3.3.orig/src/world/assembler.oak0000664000175000000620000004711707725515165017477 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Barak A. Pearlmutter ;;; Assemble Oaklisp bytecode. ;;; Input format: A single s-expr, of the form (CODE () byte-code-list) ;;; where byte-code-list is a list of bytecodes. ;;; Output format: a list of code segments, where each code segment is ;;; a list of two things: a resolution list and a list of numbers. The ;;; Some bytecodes refer ;;; to constants, such as symbols and lists. Such references are ;;; emited as zeros and information to the linker detailing the ;;; location and desired reference are emited in an epilogue. Also, ;;; there are references to global variables. These are handled in a ;;; similar fashion. ;;; The main routine is ASSEMBLE. It takes a list of bytecodes as input ;;; and returns a list of code segment descriptors, each of which is ;;; a list of bytecodes and a list of instructions to the linker. These ;;; instructions are of the form (resolution-type address thing) where ;;; resolution-type is constant, variable or code, address is a zero based ;;; offset into the code, and thing is either a constant, a symbol, or ;;; the number of another code segment. (define (assemble codelist) ;; Input is of the form (code ivar-list instruction-list). (when (> #*compiler-noisiness 1) (format #t "assembling...") (flush standard-output)) (let ((scheduled-segments (list codelist)) (segment-count 1)) (iterate aux ((output '())) (cond ((null? scheduled-segments) (reverse output)) (else (let ((assembled-segment (assemble-code-segment (car scheduled-segments)))) (set! scheduled-segments (cdr scheduled-segments)) (aux (cons (list (map (lambda (resolvant) (cond ((eq? (car resolvant) code-key) (set! segment-count (+ segment-count 1)) (set! scheduled-segments (append scheduled-segments (list (third resolvant)))) (list (first resolvant) (second resolvant) (- segment-count 1))) (else resolvant))) (first assembled-segment)) (second assembled-segment)) output)))))))) (define (assemble-code-segment l) ;; Input is of the form (code ivar-list instruction-list). (unless (eq? (car l) 'code) (error "Input does not appear to be a code segment: ~A." l)) ;; Throw the answer to OK when done. (native-catch ok (iterate infinite-loop () ;; If an already assembled instruction is hacked so badly that the whole ;; code segment has to be reassembled, throw to REASSEMBLE. (native-catch reassemble (throw ok (iterate aux ((input (third l)) (addr 2) (output '(0 0)) (label-alist '()) (patch-alist '()) (resolution-alist `((,constant-key 0 ,(second l))))) (cond ((null? input) (unless (null? patch-alist) (error "Unresolved label ~A." patch-alist)) (list (reverse resolution-alist) (reverse (if (odd? addr) (cons 0 output) output)))) (else (let* ((this (car input))) (if (eq? (car this) 'LABEL) ;; Just found a label; record it and resolve forward refs. (let ((lab (cadr this))) (aux (cdr input) addr output (cons (cons lab addr) label-alist) ;; Run through resolving forward references: (iterate aux ((l patch-alist)(o '())) (cond ((null? l) o) ((eq? (caar l) lab) ((cdr (car l)) addr) (aux (cdr l) o)) (else (aux (cdr l) (cons (car l) o))))) resolution-alist)) ;; Encode and emit instruction: (let* ((opcode (car this)) (the-opcode-descriptor (opcode-descriptor opcode))) (when (null? the-opcode-descriptor) (error "Unrecognized opcode ~A" opcode)) (destructure (opcode-field arg-field-descriptor) the-opcode-descriptor (cond ((number? arg-field-descriptor) (if (null? (cddr the-opcode-descriptor)) (aux (cdr input) (+ addr 1) (cons (construct-instruction opcode-field arg-field-descriptor) output) label-alist patch-alist resolution-alist) ;; Uh oh, requires an inline argument. (cond ((eq? (caddr the-opcode-descriptor) 'long-label) (let* ((the-label (second this)) (place (assq the-label label-alist)) (output (list* (and place (make-long-label (- (cdr place) addr 2))) (construct-instruction opcode-field arg-field-descriptor) output))) (aux (cdr input) (+ addr 2) output label-alist (if place patch-alist (cons (cons the-label (lambda (other-addr) (set! (car output) (make-long-label (- other-addr addr 2))))) patch-alist)) resolution-alist))) (else (aux (cdr input) (+ addr (+ 1 (if (odd? addr) 2 3))) (list* 0 0 (let ((new-out (cons (construct-instruction opcode-field arg-field-descriptor) output))) (if (odd? addr) new-out (cons 0 new-out)))) label-alist patch-alist (cons (list (encode-resolution-symbol (caddr the-opcode-descriptor)) (+ addr (if (odd? addr) 1 2)) (second this)) resolution-alist)))))) ((eq? arg-field-descriptor 'unsigned) (aux (cdr input) (+ addr 1) (cons (construct-instruction opcode-field (unsigned-arg (second this))) output) label-alist patch-alist resolution-alist)) ((eq? arg-field-descriptor 'signed) (aux (cdr input) (+ addr 1) (cons (construct-instruction opcode-field (signed-arg (second this))) output) label-alist patch-alist resolution-alist)) ((eq? arg-field-descriptor 'register) (aux (cdr input) (+ addr 1) (cons (construct-instruction opcode-field (register-arg (second this))) output) label-alist patch-alist resolution-alist)) ((eq? arg-field-descriptor 'label) (let* ((place (assq (second this) label-alist)) (distance (and place (- (cdr place) addr 1)))) (if (or (not place) (tiny-number? distance)) (let ((output (cons (construct-instruction opcode-field (if place (signed-arg distance) 0)) output))) (aux (cdr input) (+ addr 1) output label-alist (if place patch-alist (cons (cons (second this) (lambda (other-addr) (let ((patched-instruction (patch-branch (car output) addr other-addr))) (cond (patched-instruction (set! (car output) patched-instruction)) (else (let ((new-instructions (longify-instruction this))) (set! (car input) (car new-instructions)) (set! (cdr input) (append (cdr new-instructions) (cdr input)))) (when (> #*compiler-noisiness 1) (format #t "~&Reassembling code segment.~%")) (throw reassemble nil)))))) patch-alist)) resolution-alist)) (aux (append (longify-instruction this) (cdr input)) addr output label-alist patch-alist resolution-alist)))) ((eq? arg-field-descriptor 'blt-arg) (aux (cdr input) (+ addr 1) (cons (construct-instruction opcode-field (blt-args (second this) (third this))) output) label-alist patch-alist resolution-alist)) (else (error "Internal error; bad arg field descriptor ~S.~%" arg-field-descriptor)))))))))))) (infinite-loop)))) (define (tiny-number? x) (and (integer? x) (<= (- (expt 2 7)) x) (< x (expt 2 7)))) (define (construct-instruction opcode arg) (+ (* opcode 4) (* arg 256))) (define (patch-branch old addr other-addr) (let ((distance (- other-addr addr 1))) (if (tiny-number? distance) (+ old (* (signed-arg distance) 256)) nil))) (define (unsigned-arg x) (cond ((or (< x 0) (> x 255)) (error "~D is out of range for an unsigned arg.~%" x)) (else x))) (define (signed-arg x) (cond ((or (< x -128) (< 127 x)) (error "~D is out of range for a signed arg.~%" x)) ((< x 0) (+ 256 x)) (else x))) (define (make-long-label distance) (if (and (< (- (expt 2 13)) distance) (< distance (- (expt 2 13) 1))) (* 4 (cond ((< distance 0) (+ (expt 2 14) distance)) (else distance))) (error "Even a long label can't go a distance of ~A." distance))) (define (blt-args stuff trash) (cond ((or (<= stuff 0) (>= stuff 16) (<= trash 0) (> trash 16)) (error "Instruction (BLT-STACK ~D ~D); arguments out of range." stuff trash)) (else (+ stuff (* (- trash 1) 16))))) (define (register-arg x) (iterate aux ((l register-list)(n 0)) (cond ((null? l) ;; Return an unused register number. (warning "Unknown register ~A." x) 69) ((eq? x (car l)) n) (else (aux (cdr l) (+ n 1)))))) (define register-list '(t nil fixnum-type loc-type cons-type subtype-table bp env nargs env-type argless-tag-trap-table arged-tag-trap-table object-type boot-code free-ptr cons-limit segment-type uninitialized next-newspace-size method-type operation-type false process)) ;;; Try and longify an instruction. Return a list of opcodes to replace the old one. (define (longify-instruction x) (destructure (op . stuff) x (cond ((assq op ;; Put instructions that are easy to longify in this list: '((branch . long-branch) (branch-nil . long-branch-nil) (branch-t . long-branch-t) (push-cxt . push-cxt-long) )) => (lambda (found) (let ((new-op (cdr found))) (when (> #*compiler-noisiness 1) (format #t "~&Longifying instruction ~A to ~A.~%" x new-op)) (list (cons new-op stuff))))) ;; Put instructions that longify in some odd way in a clause here: ((eq? op 'funcall-cxt-br) (when (> #*compiler-noisiness 1) (format #t "~&Longifying instruction ~A by expanding it.~%" x)) `((funcall-cxt)(long-branch ,@stuff))) (else (error "Can't longify the ~A opcode in ~A." op x))))) (define (encode-resolution-symbol x) (cond ((eq? x 'constant) constant-key) ((eq? x 'variable) variable-key) ((eq? x 'code) code-key) (else (error "Can't encode resolution symbol ~S." x)))) ;;; The mechanism for storing opcode descriptions: (define-instance opcode-descriptor settable-operation) (define opcode-descriptor-hash-table (make-eq-hash-table)) (add-method (opcode-descriptor (object) opcode) (cond ((present? opcode-descriptor-hash-table opcode) => cdr) (else #f))) (add-method ((setter opcode-descriptor) (object) opcode description) (set! (present? opcode-descriptor-hash-table opcode) description)) ;;; The mechanism for storing opcode notations: (define-instance opcode-notation settable-operation) (define opcode-notation-hash-table (make-eq-hash-table)) (add-method (opcode-notation (object) opcode) (cond ((present? opcode-notation-hash-table opcode) => cdr) (else #f))) (add-method ((setter opcode-notation) (object) opcode notation) (set! (present? opcode-notation-hash-table opcode) notation)) ;; Possible notations: ;; branch (some kind of branch) ;; in0 ;; in1 ;; in2 ;; in3 ;; inn (number consumed determined by inline argument) ;; out0 ;; out1 ;; notnil (never returns nil, out1 must be true) ;; nosides (no side effects) ;; commutes (commutative, in2 must be true) ;; ns (no stack except formals) ;;; Some syntax: (local-syntax (define-opcode opcode description . notation) `(block (set! (opcode-descriptor ',opcode) ',description) (set! (opcode-notation ',opcode) ',notation))) ;;; Describe all the opcodes: (define-opcode halt (1 unsigned) in1 ns) (define-opcode log-op (2 unsigned) in2 out1 notnil nosides ns) (define-opcode blt-stk (3 blt-arg)) (define-opcode branch-nil (4 label) in1 branch ns) (define-opcode branch-t (5 label) in1 branch ns) (define-opcode branch (6 label) in0 branch ns) (define-opcode pop (7 unsigned) inn out0 ns) (define-opcode swap (8 unsigned) in1 out1) (define-opcode blast (9 unsigned) in1 out0) (define-opcode load-imm-fix (10 signed) in0 out1 notnil nosides ns) (define-opcode store-stk (11 unsigned) in1 out1) (define-opcode load-bp (12 unsigned) in0 out1 nosides ns) (define-opcode store-bp (13 unsigned) in1 out1 ns) (define-opcode load-env (14 unsigned) in0 out1 nosides ns) (define-opcode store-env (15 unsigned) in1 out1 ns) (define-opcode load-stk (16 unsigned) in0 out1 nosides) (define-opcode make-bp-loc (17 unsigned) in0 out1 notnil nosides ns) (define-opcode make-env-loc (18 unsigned) in0 out1 notnil nosides ns) (define-opcode store-reg (19 register) in1 out1 ns) (define-opcode load-reg (20 register) in0 out1 nosides ns) ; special case: (define-opcode funcall-cxt (21 0)) (define-opcode funcall-cxt-br (21 label)) ; opcode chosen for clean emulator implementation: (define-opcode funcall-tail (22 0)) (define-opcode store-nargs (23 unsigned) in0 out0 ns) (define-opcode check-nargs (24 unsigned) in1 out0 ns) (define-opcode check-nargs-gte (25 unsigned) in1 out0 ns) (define-opcode store-slot (26 unsigned) in2 out1 ns) (define-opcode load-slot (27 unsigned) in1 out1 nosides ns) (define-opcode make-closed-environment (28 unsigned) inn out1 notnil nosides ns) (define-opcode push-cxt (29 label) in0 out0 ns) (define-opcode locate-slot (30 unsigned) in1 out1 notnil nosides ns) (define-opcode stream-primitive (31 unsigned) out1 ns) (define-opcode filltag (32 unsigned) in1 out1 ns) ; special case (define-opcode ^super-cxt (33 0)) (define-opcode ^super-cxt-br (33 label)) ; opcode chosen for clean emulator implementation (define-opcode ^super-tail (34 0)) (define-opcode noop (0 0) in0 out0 nosides ns) (define-opcode plus (0 1) in2 out1 notnil nosides commutes ns) (define-opcode negate (0 2) in1 out1 notnil nosides ns) (define-opcode eq? (0 3) in2 out1 nosides commutes ns) (define-opcode not (0 4) in1 out1 nosides ns) (define-opcode times (0 5) in2 out1 notnil nosides commutes ns) (define-opcode load-glo (0 6 variable) in0 out1 nosides ns) (define-opcode load-code (0 6 code) in0 out1 nosides ns) (define-opcode load-imm (0 6 constant) in0 out1 nosides ns) (define-opcode div (0 7) in2 out1 notnil nosides ns) (define-opcode =0? (0 8) in1 out1 nosides ns) (define-opcode get-tag (0 9) in1 out1 notnil nosides ns) (define-opcode get-data (0 10) in1 out1 notnil nosides ns) (define-opcode crunch (0 11) in2 out1 nosides ns) (define-opcode getc (0 12) in0 out1 ns) (define-opcode putc (0 13) in1 out1 ns) (define-opcode contents (0 14) in1 out1 nosides ns) (define-opcode set-contents (0 15) in2 out1 ns) (define-opcode load-type (0 16) in1 out1 nosides ns) (define-opcode cons (0 17) in2 out1 notnil nosides ns) (define-opcode <0? (0 18) in1 out1 nosides ns) (define-opcode modulo (0 19) in2 out1 notnil nosides ns) (define-opcode ash (0 20) in2 out1 notnil nosides ns) (define-opcode rot (0 21) in2 out1 notnil nosides ns) (define-opcode store-bp-i (0 22) in2 out1 ns) (define-opcode load-bp-i (0 23) in1 out1 nosides ns) (define-opcode return (0 24) ns) (define-opcode allocate (0 25) in2 out1 notnil nosides ns) (define-opcode assq (0 26) in2 out1 nosides ns) (define-opcode load-length (0 27) in1 out1 notnil nosides ns) (define-opcode peek (0 28) in1 out1 ns) (define-opcode poke (0 29) in2 out1 ns) (define-opcode make-cell (0 30) in1 out1 notnil nosides ns) (define-opcode subtract (0 31) in2 out1 notnil nosides ns) (define-opcode = (0 32) in2 out1 nosides commutes ns) (define-opcode < (0 33) in2 out1 nosides ns) (define-opcode bit-not (0 34) in1 out1 notnil nosides ns) (define-opcode long-branch (0 35 long-label) in0 branch ns) (define-opcode long-branch-nil (0 36 long-label) in1 branch ns) (define-opcode long-branch-t (0 37 long-label) in1 branch ns) (define-opcode locate-bp-i (0 38) in1 out1 notnil nosides ns) (define-opcode load-glo-con (0 39 variable) in0 out1 nosides ns) (define-opcode car (0 40) in1 out1 nosides ns) (define-opcode cdr (0 41) in1 out1 nosides ns) (define-opcode set-car (0 42) in2 out1 ns) (define-opcode set-cdr (0 43) in2 out1 ns) (define-opcode locate-car (0 44) in1 out1 nosides ns) (define-opcode locate-cdr (0 45) in1 out1 nosides ns) (define-opcode push-cxt-long (0 46 long-label) ns) ; Used by Bruce Horn for the Macintosh implementation: (define-opcode call-primitive (0 47)) (define-opcode throw (0 48) in2 ns) (define-opcode object-hash (0 49) in1 out1 notnil nosides ns) (define-opcode object-unhash (0 50) in1 out1 nosides ns) (define-opcode gc (0 51) in0 out1 ns) (define-opcode big-endian? (0 52) in0 out1 nosides ns) (define-opcode vlen-allocate (0 53) in2 out1 nosides ns) (define-opcode inc-loc (0 54) in2 out1 notnil nosides ns) (define-opcode fill-continuation (0 55) in1 out1 notnil ns) (define-opcode continue (0 56) in2 ns) (define-opcode reverse-cons (0 57) in2 out1 notnil nosides ns) (define-opcode most-negative-fixnum? (0 58) in1 out1 nosides ns) (define-opcode fx-plus (0 59) in2 out1 notnil nosides commutes ns) (define-opcode fx-times (0 60) in2 out1 notnil nosides commutes ns) (define-opcode get-time (0 61) in0 out1 notnil nosides ns) (define-opcode remainder (0 62) in2 out1 notnil nosides ns) (define-opcode quotientm (0 63) in2 out1 notnil nosides ns) (define-opcode full-gc (0 64) in0 out1 ns) (define-opcode make-lambda (0 65) in2 out1 notnil nosides ns) (define-opcode get-argline-char (0 66) in2 out1 nosides ns) (define-opcode enable-alarms (0 67) in0 out1 ns) (define-opcode disable-alarms (0 68) in0 out1 ns) (define-opcode reset-alarm-counter (0 69) in0 out1 ns) (define-opcode make-heavyweight-thread (0 70) in1 out0 ns) (define-opcode test-and-set-locative (0 71) in3 out1 ns) ;;; Bitwise operations are translated into LOG-OPs with the ;;; appropriate bitfields. Fill in the following truth table, and ;;; then construct a bitfield with the bits you get, as below. ;;; ;;; X ;;; 0 1 ;;; ------- ;;; 0 | 8 | 4 | ;;; Y | - - - | ;;; 1 | 2 | 1 | ;;; ------- ;;; ;;; #b8421 (define-opcode bit-and (2 #b0001) in2 out1 notnil nosides commutes ns) (define-opcode bit-nand (2 #b1110) in2 out1 notnil nosides commutes ns) (define-opcode bit-or (2 #b0111) in2 out1 notnil nosides commutes ns) (define-opcode bit-nor (2 #b1000) in2 out1 notnil nosides commutes ns) (define-opcode bit-xor (2 #b0110) in2 out1 notnil nosides commutes ns) (define-opcode bit-equiv (2 #b1001) in2 out1 notnil nosides commutes ns) (define-opcode bit-andca (2 #b0100) in2 out1 notnil nosides ns) ;;; List all the instructions with certain attributes. (define (instructions-with attributes) (iterate aux ((l (#^list-type opcode-notation-hash-table)) (yes '())) (cond ((null? l) yes) ((subset? attributes (cdr (car l))) (aux (cdr l) (cons (caar l) yes))) (else (aux (cdr l) yes))))) ;;; eof oaklisp-1.3.3.orig/src/world/multiproc-tests.oak0000664000175000000620000000373711036404032020654 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;; regression tests start here... (process-id (current-process)) (%make-heavyweight-thread start-busy-work) (define x (make mutex)) (acquire-mutex x) (release-mutex x) (define y (delay (+ 1 2))) (define z (future (+ 1 2))) (define (test-fn) (while t (format t "~s~%" (process-id (current-process))))) (process-run-fn test-fn nil) (process-run-fn test-fn nil) (process-run-fn test-fn nil) (test-fn) (set! #*thing 'adf) #*thing ; Should return symbol ADF (bind ((#*hello "hello")) #*hello) ; Returns "hello" #*hello ; Should error (bind ((#*hello "hello")) (set! #*world "world")) #*world ; Returns "world" #*hello ; Should error (set! #*forcible-print-magic #f) ;;; TO DO ;;; register for # instructions until alarms ? ;;; at least make interval modifiable ;;; change C thread maker so malloc'ed stuff doesn't get into oaklisp space ;;; rationalize process descriptor table C vs Oaklisp interface ;;; process priorities ;;; make threads extra "level" in build process. Prior to that being ;;; loaded, NO THREAD STUFF AT ALL. ;;; ability to build emulator without thread support ;;; race conditions (symbol tables, hash tables, add-method) ;;; performance ;;; make sure throwing out of thread gets an error ;;; completely rewrite allocation subsystem oaklisp-1.3.3.orig/src/world/mac-compiler-nodes.oak0000664000175000000620000002105407725515165021170 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang and Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; define the AST node types ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-instance ast-node type '(enclosing-contour stack-map) (list object)) (define-instance ast-constant-node type '(value name ;name is for documentation purposes origin) ;origin holds folded node (list ast-node)) (define-instance ast-if-node type '(predicate consequent alternate) (list ast-node)) (define-instance ast-set-node type '(variable expression) (list ast-node)) (define-instance ast-contour-node type '(localvars ;names added in this contour nojumplist ;localvars that are referenced except in car position closedlist ;localvars that are closed over environment ;lexically apparent external variables envlist) ;external variables that are closed over (list ast-node)) (define-instance ast-method-node type '(method-type ;type to add the method to op ;the operation status ;'method,'inline, or 'code inlabels? ;labels clauses are special ivarlist ;ivars declared ivarmap ;assumed layout of ivars in type arglist ;arguments declared heaplist ;args that must be moved to heap primitivep ;whether its the crude open coded kind body rest-name) (list ast-contour-node)) (define-instance ast-labels-node type '(labellist ;label names lambdalist ;this is a rib parallel to labellist gensymlist ;another rib body) ;we'll keep this here for now (list ast-contour-node)) (define-instance ast-make-locative-node type '(variable) (list ast-node)) (define-instance ast-block-node type '(body) (list ast-node)) (define-instance ast-variable-node type '(var-type name source-contour car-pos?) (list ast-node)) (define-instance ast-combination-node type '(op args tail-pos? rest-name) (list ast-node)) (define-instance ast-catch-node type '(expression) (list ast-node)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; set up accessors ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (create-setters ast-block-node blkn- body) (create-setters ast-constant-node constn- value name origin) (create-setters ast-node node- enclosing-contour) (create-setters ast-method-node methn- inlabels?) (create-accessors ast-node node- stack-map) (create-accessors ast-if-node ifn- predicate consequent alternate) (create-accessors ast-set-node setn- variable expression) (create-accessors ast-contour-node contn- localvars envlist closedlist nojumplist environment) (create-accessors ast-method-node methn- method-type op status ivarlist arglist heaplist ivarmap rest-name body) (create-accessors ast-labels-node labn- gensymlist labellist lambdalist body) (create-accessors ast-make-locative-node maklocn- variable) (create-accessors ast-variable-node varn- var-type name source-contour car-pos?) (create-accessors ast-combination-node combn- op args tail-pos? rest-name) (create-accessors ast-catch-node catchn- expression) (define-set-manager heap? ast-method-node heaplist) (define-set-manager evar? ast-contour-node envlist) (define-set-manager localvar? ast-contour-node localvars) (define-set-manager closed-over? ast-contour-node closedlist) (define-set-manager cant-jump? ast-contour-node nojumplist) (add-method (equal? (ast-constant-node value) self x) (equal? value x)) ;notice this function is not symmetric ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; debugging stuff ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;listify takes an AST and converts it to a list representation suitable for printing (define-instance listify operation) (add-method (listify (ast-node) self) '(astn)) (add-method (listify (ast-if-node predicate consequent alternate) self) (list 'ifn (listify predicate) (listify consequent) (listify alternate))) (add-method (listify (ast-constant-node value name) self) (if name (list 'constn value name) (list 'constn value))) (add-method (listify (ast-set-node variable expression) self) (list 'setn (listify variable) (listify expression))) (add-method (listify (ast-method-node method-type status op ivarlist arglist inlabels? primitivep heaplist ivarmap body) self) (list (if primitivep 'primethn 'methn) (if inlabels? (list 'inlabels status) status) `(type ,(listify method-type)) `(op ,(listify op)) `(ivars ,@ivarlist) `(args ,@arglist) `(heap ,@heaplist) `(env ,@(contn-envlist self)) `(loc ,@(contn-localvars self)) `(lex ,@(contn-environment self)) `(closed ,@(contn-closedlist self)) `(nojump ,@(contn-nojumplist self)) (listify body))) (add-method (listify (ast-labels-node labellist gensymlist lambdalist body) self) (list 'labn labellist gensymlist `(closed ,@(contn-closedlist self)) `(nojump ,@(contn-nojumplist self)) (map listify lambdalist) (listify body))) (add-method (listify (ast-contour-node localvars) self) (list 'contn (contn-transparent? self) localvars)) (add-method (listify (ast-make-locative-node variable) self) (list 'maklocn (listify variable))) (add-method (listify (ast-block-node body) self) `(blkn ,@(map listify body))) (add-method (listify (ast-variable-node var-type name) self) (list var-type name)) (add-method (listify (ast-combination-node op args tail-pos? rest-name) self) (let ((mylist `(,(if tail-pos? 'tailcombn 'combn) ,(listify op) ,@(map listify args)))) (if (eq? rest-name nichevo) mylist (list* 'restcall (listify rest-name) mylist)))) (add-method (listify (ast-catch-node expression) self) (list 'catchn (listify expression))) (add-method (print (ast-node) self stream) (print (listify self) stream)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; define methods for walking the AST ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (local-syntax add-map-walk (lambda (form) (let ((typ (second form)) (vars (cddr form)) (arg (genvar)) (op (genvar))) (let ((fixedvars (map (lambda (x) (if (atom? x) x (car x))) vars))) `(block (add-method (walk-ast (,typ . ,fixedvars) self ,op) ,@(map (lambda (x) (if (atom? x) `(,op ,x) `(for-each ,op ,(car x)))) vars) ,@(if vars '() '(nil))) (add-method (map-ast! (,typ . ,fixedvars) self ,op) ,@(map (lambda (x) (if (atom? x) `(set! ,x (,op ,x)) `(set! ,(car x) (map ,op ,(car x))))) vars) self) (add-method (walk-ast-with-arg (,typ . ,fixedvars) self ,op ,arg) ,@(map (lambda (x) (if (atom? x) `(,op ,x ,arg) `(walk-with-arg ,op ,(car x) ,arg))) vars) ,@(if vars '() '(nil))) (add-method (map-ast-with-arg! (,typ . ,fixedvars) self ,op ,arg) ,@(map (lambda (x) (if (atom? x) `(set! ,x (,op ,x ,arg)) `(set! ,(car x) (map-with-arg ,op ,(car x) ,arg)))) vars) self)))))) (define-instance walk-ast operation) (define-instance map-ast! operation) (define-instance walk-ast-with-arg operation) (define-instance map-ast-with-arg! operation) (add-map-walk ast-if-node predicate consequent alternate) (add-map-walk ast-node) (add-map-walk ast-constant-node origin) (add-map-walk ast-set-node variable expression) (add-map-walk ast-variable-node) (add-map-walk ast-method-node op method-type body) (add-map-walk ast-labels-node body (lambdalist)) (add-map-walk ast-make-locative-node variable) (add-map-walk ast-block-node (body)) (add-map-walk ast-combination-node op (args) rest-name) (add-map-walk ast-catch-node expression) oaklisp-1.3.3.orig/src/world/print.oak0000664000175000000620000000276407725515165016655 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;;; Print methods for some standard system types that print in a simple way. (define (define-simple-print-method typ name) (add-method (print (typ) self stream) (format stream "#<~A ~!>" name self) self)) (define-simple-print-method object "Object") (define-simple-print-method type "Type") (define-simple-print-method coercable-type "Coercable") (define-simple-print-method operation "Op") (define-simple-print-method settable-operation "SettableOp") (define-simple-print-method locatable-operation "LocatableOp") (define-simple-print-method variable-length-mixin "VLmixin") (add-method (print (locative) self stream) ;(format stream "#" self (contents self)) (format stream "#" self)) ;;; eof oaklisp-1.3.3.orig/src/world/mac-compiler2.oak0000664000175000000620000003532007725515165020145 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;;; Copyright (C) 1986 Kevin J. Lang and Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; top-level compiler sequencer ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-instance compile operation) (define-instance expand-compile operation) (labels (((annotate-the-tree astree) (block (when #*contour-nodes? (mark-inline-lambdas astree) (if (> #*labels-count 0) (mark-tail-nodes astree))) (top-level-resolve-variables astree)))) (add-method (expand-compile (locale) self form) (compile self (block0 (expand-groveling self form) (print-sp 'mac)))) (add-method (compile (locale) self form) (bind ((#*labels-count 0) (#*contour-nodes? #f) (#*barrier-node #f) (#*worry-about-constants #f)) (let ((astree (bind ((#*worry-about-constants #t)) (code->ast form)))) (print-sp 'tree) (annotate-the-tree astree) (print-sp 'ann) (iterate step ((pre-count #*labels-count)) (print-sp #*labels-count) (when (> #*labels-count 0) (set! astree (rewrite-labels-v astree)) (when (not (= pre-count #*labels-count)) (annotate-the-tree astree) (print-sp 'ann) (step #*labels-count)))) (set! astree (fold-constants-v astree self)) (print-sp 'fold) (when #*contour-nodes? (set! astree (insert-method-maker-v astree))) (print-sp 'insert) (set! astree (heapify-variables-v astree)) (print-sp 'heap) (when #*contour-nodes? (stash-stack-map astree nil)) (print-sp 'stack) (set! dog2 astree) astree)))) ; NAMING CONVENTION: ;All of the AST-walking operations defined below perform side effects on ;the tree. If an operation actually deletes and inserts nodes, then the value ;it returns is important, so its name should end in "-v". ;If the side effects are only on the internal state of the ;nodes, then the name should have no suffix. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; identify inline lambdas ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;This step marks methods generated from lambdas in the car position ;by changing their status from 'method to 'inline. ;Labels nodes already have a status of 'inline. (define-instance mark-inline-lambdas operation) (with-operations (you-are-in-car-pos) (add-method (mark-inline-lambdas (ast-node) self) (walk-ast self mark-inline-lambdas)) (add-method (mark-inline-lambdas (ast-variable-node car-pos?) self) (set! car-pos? nil)) ;erase previous analysis (add-method (mark-inline-lambdas (ast-method-node status inlabels?) self) (set! status 'method) ;erase previous analysis (set! inlabels? nil) ;erase previous analysis (walk-ast self mark-inline-lambdas)) (add-method (mark-inline-lambdas (ast-combination-node op) self) (walk-ast self mark-inline-lambdas) (you-are-in-car-pos op)) (add-method (mark-inline-lambdas (ast-labels-node lambdalist) self) (walk-ast self mark-inline-lambdas) ;; These guys must be marked as inline, (for-each you-are-in-car-pos lambdalist) ;; and inlabels. (walk-with-arg (setter methn-inlabels?) lambdalist t)) (add-method (you-are-in-car-pos (ast-node) self) t) ;no-op (add-method (you-are-in-car-pos (ast-variable-node car-pos?) self) (set! car-pos? t)) (add-method (you-are-in-car-pos (ast-method-node status rest-name) self) (if (and (am-I-a-lambda? self) (not rest-name)) (set! status 'inline))) ) #| ;old versions of the above. (add-method (you-are-in-car-pos (ast-method-node status op ivarlist method-type) self) (if (and (null? ivarlist) ;No ivars. (and (is-a? op ast-combination-node) (is-a? (combn-op op) ast-variable-node) (equal? (varn-name (combn-op op)) 'make) ;Operation is made at (= 1 (length (combn-args op))) ;installation time. (is-a? (car (combn-args op)) ast-variable-node) (equal? (varn-name (car (combn-args op))) 'operation)) (is-a? method-type ast-variable-node) ;Method is for object. (equal? 'object (varn-name method-type))) ; (set! status 'inline))) (add-method (you-are-in-car-pos (ast-method-node status op ivarlist method-type) self) (if (and (null? ivarlist) ;No ivars. (and (is-a? op ast-combination-node) (equal? (combn-op op) make);Operation is made at (= 1 (length (combn-args op)));installation time. (equal? (car (combn-args op)) operation)) (is-a? method-type ast-constant-node);Method is for object. (eq? object (constn-value method-type))) (set! status 'inline))) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;Define contour-transparency, which is the ability to search on up ;through the contour for names, as opposed to closing over them. (define-instance contn-transparent? operation) (add-method (contn-transparent? (ast-contour-node) self) nil) (add-method (contn-transparent? (ast-method-node status) self) (eq? status 'inline)) (add-method (contn-transparent? (ast-labels-node) self) t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; identify combinations in tail-recursive spots relative to labels ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-instance mark-tail-nodes operation) (with-operations (you-are-in-tail-pos) (add-method (mark-tail-nodes (ast-node) self) (walk-ast self mark-tail-nodes)) (add-method (mark-tail-nodes (ast-labels-node) self) (walk-ast self mark-tail-nodes) (you-are-in-tail-pos self)) (add-method (mark-tail-nodes (ast-combination-node tail-pos?) self) (set! tail-pos? nil) ;erase previous analysis (walk-ast self mark-tail-nodes)) (add-method (you-are-in-tail-pos (ast-node) self) nil) ;no-op (add-method (you-are-in-tail-pos (ast-if-node consequent alternate) self) (you-are-in-tail-pos consequent) (you-are-in-tail-pos alternate)) (add-method (you-are-in-tail-pos (ast-labels-node) self) (walk-ast self you-are-in-tail-pos)) (add-method (you-are-in-tail-pos (ast-block-node body) self) (you-are-in-tail-pos (last body))) (add-method (you-are-in-tail-pos (ast-combination-node op tail-pos?) self) (set! tail-pos? t) (if (is-a? op ast-method-node) (you-are-in-tail-pos op))) ;so that LET will work. (add-method (you-are-in-tail-pos (ast-method-node status body) self) (if (eq? status 'inline) (you-are-in-tail-pos body)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; resolve lexical variables ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;sequencer for variable resolution (define-instance top-level-resolve-variables operation) (define-instance resolve-variables operation) (add-method (top-level-resolve-variables (ast-node) self) (let ((dummy-contour (make ast-contour-node nil nil))) (resolve-variables self '() dummy-contour))) (add-method (resolve-variables (ast-node) self outerenv outermethod) (stash-environment self outerenv) (stash-enclosing-contour self outermethod) (classify-variables self) (propagate-evars self)) (set! dummy-contour (make ast-contour-node nil nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;The environment slot of a contour node contains a list of all ;external lexical variables that are visible in that method. (define-instance stash-environment operation) (add-method (stash-environment (ast-node) self outer-env) (walk-ast-with-arg self stash-environment outer-env)) (add-method (stash-environment (ast-contour-node localvars environment) self outer-env) (set! environment outer-env) (append localvars outer-env)) (add-method (stash-environment (ast-method-node method-type op body) self outer-env) (let ((new-env (^super ast-contour-node stash-environment self outer-env))) (stash-environment method-type outer-env) (stash-environment op outer-env) (stash-environment body new-env))) (add-method (stash-environment (ast-labels-node lambdalist body) self outer-env) (let ((new-env (^super ast-contour-node stash-environment self outer-env))) (map-with-arg stash-environment lambdalist new-env) (stash-environment body new-env))) #| (with-operations (proceed) (add-method (stash-environment (ast-contour-node localvars environment) self outer-env) (set! environment outer-env) (proceed self outer-env (append localvars outer-env))) (add-method (proceed (ast-method-node method-type op body) self outer-env new-env) (stash-environment method-type outer-env) (stash-environment op outer-env) (stash-environment body new-env)) (add-method (proceed (ast-labels-node lambdalist body) self outer-env new-env) (map-with-arg stash-environment lambdalist new-env) (stash-environment body new-env))) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;The enclosing-contour slot of a node provides a pointer back to the contour ;that contains the node. This facilitates references to the various ;variable lists in the method. The outermost nodes point back ;to a dummy contour that has no arguments. (define-instance stash-enclosing-contour operation) (with-operations (proceed) (add-method (stash-enclosing-contour (ast-node enclosing-contour) self enc-cont) (set! enclosing-contour enc-cont) (proceed self enc-cont)) (add-method (proceed (ast-node) self enc-cont) (walk-ast-with-arg self stash-enclosing-contour enc-cont)) (add-method (proceed (ast-method-node method-type op body) self enc-cont) (stash-enclosing-contour method-type enc-cont) (stash-enclosing-contour op enc-cont) (stash-enclosing-contour body self)) (add-method (proceed (ast-labels-node lambdalist body) self enc-cont) (map-with-arg stash-enclosing-contour lambdalist self) (stash-enclosing-contour body self))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;The classify-variables operation figures out where variables live, ;e.g. on the stack, in the closed-environment, or wherever. (define-instance classify-variables operation) (add-method (classify-variables (ast-node) self) (walk-ast self classify-variables)) (add-method (classify-variables (ast-variable-node var-type name source-contour) self) (iterate step ((contour (node-enclosing-contour self))) (cond ((memq name (contn-localvars contour)) (set! source-contour contour) (set! var-type (cond ((is-a? contour ast-labels-node) 'label) ((memq name (methn-arglist contour)) ;it's a method 'stack) (else 'ivar)))) ((contn-transparent? contour) (step (node-enclosing-contour contour))) ((memq name (contn-environment contour)) (set! source-contour contour) (set! var-type 'evar)) (else (set! var-type 'global))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;This operation notices evars and records them in the envlist ;field of their enclosing methods. ;If a method cannot supply a variable closed over by an ;inner method, then the variable must be closed over by ;the outer method too. ;This also fills in the nojumplist field of contours. (define-instance propagate-evars operation) (add-method (propagate-evars (ast-node) self) (walk-ast self propagate-evars)) (add-method (propagate-evars (ast-variable-node var-type name source-contour car-pos?) self) (cond ((eq? var-type 'evar) (set! (evar? source-contour name) t)) ((and (not car-pos?) (eq? var-type 'label)) (set! (cant-jump? source-contour name) t)))) (add-method (propagate-evars (ast-contour-node envlist closedlist nojumplist) self) (set! envlist '()) (set! closedlist '()) (set! nojumplist '()) (walk-ast self propagate-evars) (for-each (lambda (x) (iterate step ((contour (node-enclosing-contour self))) (cond ((localvar? contour x) (set! (closed-over? contour x) t)) ((contn-transparent? contour) (step (node-enclosing-contour contour))) (else (set! (closed-over? contour x) t) (set! (evar? contour x) t))))) envlist) (set! nojumplist (append nojumplist closedlist))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; rewrite non-jumpable labels ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;a labels can be compiled using jumps if every reference to a label ;is a function call in a tail recursive position. (define-instance rewrite-labels-v operation) (with-operations (look-for-non-tail-call your-out-of-place) (add-method (rewrite-labels-v (ast-node) self) (map-ast! self rewrite-labels-v)) (add-method (rewrite-labels-v (ast-labels-node labellist lambdalist body) self) (map-ast! self rewrite-labels-v) (look-for-non-tail-call self) (if (or (contn-nojumplist self) (any? methn-rest-name lambdalist)) (block (set! #*labels-count (- #*labels-count 1)) (code->ast `((%add-method ((',make ',operation) (',object) . ,labellist) ;see below (%block ,@(map2 (lambda (lab lam) `(%set ,lab ,lam)) labellist lambdalist) ,body)) ,@(map (lambda (x) nil) ;should really be undefined value labellist)))) self)) (add-method (look-for-non-tail-call (ast-node) self) (walk-ast self look-for-non-tail-call)) (add-method (look-for-non-tail-call (ast-combination-node op tail-pos?) self) (walk-ast self look-for-non-tail-call) (if (not tail-pos?) (your-out-of-place op))) (add-method (your-out-of-place (ast-node) self) nil) (add-method (your-out-of-place (ast-variable-node var-type name source-contour) self) (if (eq? var-type 'label) (set! (cant-jump? source-contour name) t)))) ;;was `((%add-method ((make operation) (object) . ,labellist) oaklisp-1.3.3.orig/src/world/strings.oak0000664000175000000620000002744707725515165017217 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Barak A. Pearlmutter and Kevin J. Lang ;;; This file defines strings. It uses the ARRAY stuff. ;;; Add in variable-length-mixin and make fancy NTH methods (initialize string '(char-count) (list simple-vector)) (define-constant %chars-per-word 3) ;;; Try to make only one empty string. The following works, because the ;;; world builder makes only one empty string. (define (make-string len) (if (zero? len) "" (let* ((word-count (quotient (+ len (- %chars-per-word 1)) %chars-per-word)) (s (make string word-count len)) (loc (make-locative (%vref s 0)))) (dotimes (i word-count s) (set! (contents (%increment-locative loc i)) (bit-or (#^number #\NULL) (bit-or (ash-left (#^number #\NULL) 8) (ash-left (#^number #\NULL) 16)))))))) (add-method (initialize (string char-count) self word-count len) (set! char-count len) self) (add-method (length (string char-count) self) char-count) ;;;;;;;;;;;;;;;;; #| (add-method (nth (string char-count) self n) (if (<= char-count n) (error "Index ~D into ~S out of bounds." n self) (%fixnum->character (bit-and #xFF (let ((d (modulo n %chars-per-word)) (x (%vref self (quotient n %chars-per-word)))) (cond ((= d 0) x) ((= d 1) (ash-left x -8)) ((= d 2) (ash-left x -16)))))))) (add-method ((setter nth) (string char-count) self n new-c) (if (<= char-count n) (error "Index ~D into ~S out of bounds." n self) (let ((m (quotient n %chars-per-word)) (i (* (modulo n %chars-per-word) 8))) (set! (%vref self m) (bit-or (bit-and (%vref self m) (bit-and #xFFFFFF (bit-not (ash-left #xFF i)))) (ash-left (%character->fixnum new-c) i)))))) |# ;;;;;;;;;;;;;;;;; (add-method (nth (string char-count) self n) (if (or (negative? n) (<= char-count n)) (error "Index ~D into ~S out of bounds." n self) (%fixnum->character (bit-and #xFF (let ((d (modulo n %chars-per-word)) (x (%vref-nocheck self (quotient n %chars-per-word)))) (cond ((= d 0) x) ((= d 1) (ash-left x -8)) ((= d 2) (ash-left x -16)))))))) (add-method ((setter nth) (string char-count) self n new-c) (if (or (negative? n) (<= char-count n)) (error "Index ~D into ~S out of bounds." n self) (let ((m (quotient n %chars-per-word)) (i (* (modulo n %chars-per-word) 8))) (set! (%vref-nocheck self m) (bit-or (bit-and (%vref-nocheck self m) (bit-and #xFFFFFF (bit-not (ash-left #xFF i)))) (ash-left (%character->fixnum new-c) i)))))) (add-method ((locater nth) (string) self n) (error "sorry, (locater nth) doesn't work on strings (e.g. ~a)" self)) ;;;;;;;;;;;;;;;;; (define-instance upcase operation) (define-instance downcase operation) (add-method (print (string) self stream) (cond (#*print-escape (write-char stream #\") (write-string-with-slashes self #\" stream) (write-char stream #\")) (else (write-string self stream)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Coerce any kind of sequence to a string. (add-method (#^string (sequence) seq) (let* ((len (length seq)) (s (make-string len))) (iterate aux ((i 0)) (cond ((< i len) (set! (nth s i) (nth seq i)) (aux (+ i 1))) (else s))))) ;;; The following code coerces only lists to strings, but is highly optimized. ;;; This code packs characters in by threes instead of shifting and or'ing ;;; each one in individually, and avoids the overhead of the nth's. (let ((fill-string (make operation))) (add-method (fill-string (variable-length-mixin) s l len) (iterate aux ((i 0)(l l)(to-do len)) (cond ((zero? to-do) s) ((= 1 to-do) (set! (%load-bp-i i) (%character->fixnum (car l))) s) ((= 2 to-do) (set! (%load-bp-i i) (bit-or (%character->fixnum (car l)) (ash-left (%character->fixnum (cadr l)) 8))) s) (else (let* ((c0 (%character->fixnum (car l))) (l1 (cdr l)) (c1 (%character->fixnum (car l1))) (l2 (cdr l1)) (c2 (%character->fixnum (car l2)))) (set! (%load-bp-i i) (bit-or c0 (bit-or (ash-left c1 8) (ash-left c2 16)))) (aux (+ i 1) (cdr l2) (- to-do %chars-per-word))))))) (add-method (#^string (list-type) l) (if (null? l) "" (let* ((len (length l)) (s (make string (quotient (+ len (- %chars-per-word 1)) %chars-per-word) len))) (fill-string s l len) )))) ; Note: the following 3 macros exist ONLY to ; improve the readability of the following procedure. ; They use %load-bp-i, and hence will break in other contexts. (local-syntax (get-3-from-string instring i) `(let ((the-word (%load-bp-i ,i))) (list (%fixnum->character (bit-and 255 the-word)) (%fixnum->character (ash-right (bit-and (ash-left 255 8) the-word) 8)) (%fixnum->character (ash-right (bit-and (ash-left 255 16) the-word) 16))))) (local-syntax (get-2-from-string instring i) `(let ((the-word (%load-bp-i ,i))) (list (%fixnum->character (bit-and 255 the-word)) (%fixnum->character (ash-right (bit-and (ash-left 255 8) the-word) 8))))) (local-syntax (get-1-from-string instring i) `(let ((the-word (%load-bp-i ,i))) (list (%fixnum->character (bit-and 255 the-word))))) (let ((quick-vref-helper (make operation))) (add-method (quick-vref-helper (variable-length-mixin) instring char-count) (let* ((n-in-last (modulo char-count %chars-per-word)) (n-full-words (quotient char-count %chars-per-word))) (iterate loop ((outlist (if (zero? n-in-last) '() (if (= 1 n-in-last) (get-1-from-string instring n-full-words) (get-2-from-string instring n-full-words)))) (down-counter (- n-full-words 1))) (if (negative? down-counter) outlist (let ((next-triple (get-3-from-string instring down-counter))) (set (cdddr next-triple) outlist) (loop next-triple (- down-counter 1))))))) (add-method (#^list-type (string char-count) instring) (quick-vref-helper instring char-count))) #| (add-method (#^string (list-type) l) (if (null? l) "" (let* ((len (length l)) ;;(s (make-string len)) (s (make string (quotient (+ len (- %chars-per-word 1)) %chars-per-word) len))) (iterate aux ((i 0)(l l)(to-do len)) (cond ((zero? to-do) s) ((= 1 to-do) (set! (%vref s i) (%character->fixnum (car l))) s) ((= 2 to-do) (set! (%vref s i) (bit-or (%character->fixnum (car l)) (ash-left (%character->fixnum (cadr l)) 8))) s) (else (let* ((c0 (%character->fixnum (car l))) (l1 (cdr l)) (c1 (%character->fixnum (car l1))) (l2 (cdr l1)) (c2 (%character->fixnum (car l2)))) (set! (%vref s i) (bit-or c0 (bit-or (ash-left c1 8) (ash-left c2 16)))) (aux (+ i 1) (cdr l2) (- to-do %chars-per-word))))))))) |# (add-method (#^string (character) s) (#^string (list s))) (define-instance write-string operation) (add-method (write-string (string char-count) self stream) (dotimes (i char-count) (write-char stream (nth self i)))) (add-method (reverse (string char-count) self) (let ((new (make-string char-count))) (dotimes (i char-count new) (set! (nth new i) (nth self (- char-count (+ i 1))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; String predicates ;;; (add-method (= (string) x y) (equal? x y)) ; WARNING, the following method assumes that the ; unused high bits in the last word of a string are ; always initialized to the same value. This is currently ; true (see the make-string method), but you should watch ; out in the future. (labels (((string-guts-equal? a b n-chars) (let ((n-words (quotient (+ n-chars (- %chars-per-word 1)) %chars-per-word)) (a-loc (make-locative (%vref-nocheck a 0))) (b-loc (make-locative (%vref-nocheck b 0)))) (iterate aux ((i (- n-words 1))) (cond ((zero? i) (= (contents a-loc) (contents b-loc))) ((= (contents (%increment-locative a-loc i)) (contents (%increment-locative b-loc i))) (aux (- i 1))) (else #f)))))) (add-method (equal? (string) a b) (or (eq? a b) (and (eq? (get-type a) (get-type b)) (let ((l (length a))) (and (= l (length b)) (or (zero? l) (string-guts-equal? a b l)))))))) (add-method (< (string) s1 s2) (let ((l1 (length s1)) (l2 (length s2))) (iterate aux ((i 0)) (cond ((= i l2) #f) ((= i l1) #t) ((< (%character->fixnum (nth s1 i)) (%character->fixnum (nth s2 i))) #t) ((> (%character->fixnum (nth s1 i)) (%character->fixnum (nth s2 i))) #f) (else (aux (+ i 1))))))) (add-method (upcase (character) c) (let ((c (%character->fixnum c))) (%fixnum->character (cond ((and (<= (#^number #\a) c) (<= c (#^number #\z))) (- c (- (#^number #\a) (#^number #\A)))) (else c))))) (add-method (downcase (character) c) (let ((c (%character->fixnum c))) (%fixnum->character (cond ((and (<= (#^number #\A) c) (<= c (#^number #\Z))) (- c (- (#^number #\A) (#^number #\a)))) (else c))))) (add-method (upcase (string) self) (#^string (map upcase (#^list-type self)))) (add-method (downcase (string) self) (#^string (map downcase (#^list-type self)))) (define (write-string-with-slashes s delimiter-to-avoid stream) (dotimes (i (length s)) (let ((c (nth s i))) (if (or (eq? c delimiter-to-avoid) (eq? c #\\)) (write-char stream #\\)) (write-char stream c)))) (define-instance requires-slashification? operation) (add-method (requires-slashification? (string) s) (let ((len (length s))) (iterate aux ((i 0)) (if (= i len) #f (let ((c (nth s i))) (or (eq? c #\") (eq? c #\\) (aux (+ i 1)))))))) ; the coercion here between strings and char-lists ; is for speed, not just convenience. (add-method (append (string) . rest) (listify-args (lambda (args) (#^string (apply append (map (lambda (x) (let ((x (if (is-a? x forcible) (force x) x))) (if (not (string? x)) (append-type-error "string" x) (#^list-type x)))) args)))) . rest)) #| (add-method (append (string char-count) x y) (let* ((y (#^string y)) (l1 (length y)) (l2 (+ char-count l1)) (s (make-string l2))) (dotimes (i char-count (iterate aux ((i char-count) (j 0)) (cond ((< j l1) (set! (nth s i) (nth y j)) (aux (+ i 1) (+ j 1))) (else s)))) (set! (nth s i) (nth x i))))) |# ; this method is simply wrong ; (add-method (copy (string char-count) s) ; (if (zero? char-count) s ; (let ((l (quotient (+ len (- %chars-per-word 1)) %chars-per-word)) ; (n (make string l char-count))) ; (dotimes (i l n) ; (set! (%vref n i) (%vref s i)))))) (add-method (copy (string char-count) s) (if (zero? char-count) s (let* ((l (quotient (+ char-count (- %chars-per-word 1)) %chars-per-word)) (n (make string l char-count))) (dotimes (i l n) (set! (%vref n i) (%vref s i)))))) (add-method (subseq (string) self index len) (let ((new (make-string len))) (dotimes (i len) (set! (nth new i) (nth self (+ index i)))) new)) ;;; eof oaklisp-1.3.3.orig/src/world/apropos.oak0000664000175000000620000000403707725515165017177 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter (define-instance apropos operation) (with-operations (apropos2) (let ((check-in-list-and-print (lambda (place list-of-pairs key) (let ((skey (upcase (#^string key)))) (bind ((#*fancy-references #t)) (format #t "~&In ~A:~%" place)) (dolist (x list-of-pairs) (when (subsequence? skey (#^string (car x))) (format #t " ~A~%" (car x)))))))) (add-method (apropos (object) key . args) (cond ((= 0 (rest-length args)) (apropos2 #*current-locale key)) ((= 1 (rest-length args)) (apropos2 key . args)) (else (error "try (apropos ) ")))) (add-method (apropos2 (object) key place) (error "try (apropos ).~%")) (add-method (apropos2 (symbol) key place) (apropos2 place key)) (add-method (apropos2 (string) key place) (apropos2 place key)) (add-method (apropos2 (locale variable-table macro-alist) self key) (check-in-list-and-print self (#^list-type variable-table) key) (check-in-list-and-print "macro table" macro-alist key) (check-in-list-and-print "top level fluid variables" top-level-fluid-binding-list key)) (add-method (apropos2 (hash-table) self key) (check-in-list-and-print self (#^list-type self) key)))) ;;; eof oaklisp-1.3.3.orig/src/world/subprimitive.oak0000664000175000000620000002031007725515165020226 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter (define-constant %fixnum-tag 0) (define-constant %immediate-tag 1) (define-constant %locative-tag 2) (define-constant %pointer-tag 3) (define-constant %character-subtag (bit-or (ash-left 0 2) %immediate-tag)) (define-constant %wp-subtag (bit-or (ash-left 1 2) %immediate-tag)) (define-constant %increment-locative (add-method ((make-open-coded-operation '((inc-loc)) 2 1) (locative) self i) (%increment-locative self i))) (define-constant (%set-tag ref tag) (%crunch (%data ref) tag)) (define-constant get-type (add-method ((make-foldable-open-coded-operation '((load-type)) 1 1) (object) self) (get-type self))) (define-constant get-time (add-method ((make-open-coded-operation '((get-time)) 0 1) (object)) (get-time))) (define-constant %get-length (add-method ((make-open-coded-operation '((load-length)) 1 1) (object) self) (%get-length self))) #|| ;;; Maybe %get-length should not be open coded, but rather should be ;;; defined as follows. The LOAD-LENGTH instructions could then be ;;; removed from the emulator. (define (%get-length x) (let ((typ (get-type x))) (if ((%slot 2) typ) ((%slot 1) x) ((%slot 1) typ)))) ||# (define-constant eq? (add-method ((make-foldable-open-coded-operation '((eq?)) 2 1) (object) x y) (eq? x y))) (define-constant null? (add-method ((make-foldable-open-coded-operation '((not)) 1 1) (object) x) (null? x))) (define-constant not null?) (define-constant %allocate (add-method ((make-open-coded-operation '((allocate)) 2 1) (type) self size) (%allocate self size))) (define-constant %varlen-allocate (add-method ((make-open-coded-operation '((vlen-allocate)) 2 1) (type) self size) (%varlen-allocate self size))) (define-constant %data (add-method ((make-open-coded-operation '((get-data)) 1 1) (object) self) (%data self))) (define-constant %pointer %data) (define-constant %tag (add-method ((make-foldable-open-coded-operation '((get-tag)) 1 1) (object) x) (%tag x))) (define-constant %crunch (add-method ((make-open-coded-operation '((crunch)) 2 1) (fixnum) x y) (%crunch x y))) (define-constant most-negative-fixnum? (add-method ((make-foldable-open-coded-operation '((most-negative-fixnum?)) 1 1) (object) x) (most-negative-fixnum? x))) (define-constant fx-plus (add-method ((make-foldable-open-coded-operation '((fx-plus)) 2 1) (fixnum) x y) (if (eq? (get-type y) fixnum) (fx-plus x y) (error "Illegal second arg ~S to FX-PLUS." y)))) (define-constant fx-times (add-method ((make-foldable-open-coded-operation '((fx-times)) 2 1) (fixnum) x y) (if (eq? (get-type y) fixnum) (fx-times x y) (error "Illegal second arg ~S to FX-PLUS." y)))) (define-constant get-argline-char (add-method ((make-open-coded-operation '((get-argline-char)) 2 1) (fixnum) x y) (if (eq? (get-type y) fixnum) (get-argline-char x y) (error "Illegal second arg ~S to GET-ARGLINE-CHAR." y)))) ;;; The following is for use only at boot time, for feedback before the I/O system is up. (define-constant %write-char (add-method ((make-open-coded-operation '((putc)) 1 1) (character) x) (%write-char x))) (define-constant %print-digit (add-method ((make-open-coded-operation '((load-imm 48)(plus)(ash 6)(load-imm 1)(crunch)(putc)) 1 1) (integer) x) (%print-digit x))) (define-constant %read-char (add-method ((make-open-coded-operation '((getc)) 0 1) (object)) (%read-char))) (define-constant %assq (add-method ((make-open-coded-operation '((assq)) 2 1) (object) x y) (%assq x y))) ;;; This is for use in a tail recursive position when you want to fool the ;;; compiler into just emiting a return. See the code for +. (define-constant %return (add-method ((make-open-coded-operation '() 0 1) (object)) (%return))) (define-constant-instance %load-bp-i (mix-types oc-mixer (list open-coded-mixin locatable-operation)) '((load-bp-i)) 1 1) (set! (setter %load-bp-i) (make (mix-types oc-mixer (list open-coded-mixin operation)) '((store-bp-i)) 2 1)) (set! (locater %load-bp-i) (make (mix-types oc-mixer (list open-coded-mixin operation)) '((locate-bp-i)) 1 1)) (define-constant-instance %register (mix-types oc-mixer (list foldable-mixin operation))) (let ((reg-operation-alist '())) (add-method (%register (object) reg) (cond ((assq reg reg-operation-alist) => cdr) (else (let ((op (make (mix-types oc-mixer (list open-coded-mixin settable-operation)) `((load-reg ,reg)) 0 1))) (set! (setter op) (make (mix-types oc-mixer (list open-coded-mixin operation)) `((store-reg ,reg)) 1 1)) (set! reg-operation-alist (cons (cons reg op) reg-operation-alist)) op))))) (define-constant-instance %halt (mix-types oc-mixer (list foldable-mixin operation))) (let ((status-operation-alist '())) (add-method (%halt (object) status) (cond ((assq status status-operation-alist) => cdr) (else (let ((op (make (mix-types oc-mixer (list open-coded-mixin operation)) (lambda (n) `((halt ,status))) nil 1))) (add-method (op (object)) (exit status "((%HALT ~D))~%" status)) (set! status-operation-alist (cons (cons status op) status-operation-alist)) op))))) (define-constant-instance %slot (mix-types oc-mixer (list foldable-mixin operation))) (let ((slot-operation-alist '())) (add-method (%slot (object) slot) (cond ((assq slot slot-operation-alist) => cdr) (else (let ((op (make (mix-types oc-mixer (list open-coded-mixin locatable-operation)) `((load-slot ,slot)) 1 1))) (set! (setter op) (make (mix-types oc-mixer (list open-coded-mixin operation)) `((store-slot ,slot)) 2 1)) (set! (locater op) (make (mix-types oc-mixer (list open-coded-mixin operation)) `((locate-slot ,slot)) 1 1)) (set! slot-operation-alist (cons (cons slot op) slot-operation-alist)) op))))) (define-constant second-arg (add-method ((make-foldable-open-coded-operation (lambda (n) (if (< n 2) (error "A function passed ~D arguments can't return it's second." n) (list (list 'load-stk 1) (list 'blt-stk 1 n)))) nil 1) (object) a b . args) (listify-args car b . args))) (define-constant %push (add-method ((make-open-coded-operation (lambda (n) '((load-imm 0))) nil 1) (object) . args) 0)) (define-constant %make-cell (add-method ((make-open-coded-operation '((make-cell)) 1 1) (object) x) (make-locative x))) (define-constant %make-closed-environment (add-method ((make-open-coded-operation (lambda (n) (list `(make-closed-environment ,n))) nil 1) (object) . args) (listify-args (lambda (args) (let* ((l (length args)) (v (make %closed-environment l))) (dotimes (i l) (set! (nth v i)(nth args i))) v)) . args))) (define-constant %big-endian? (add-method ((make-open-coded-operation '((big-endian?)) 0 1) (object)) (%big-endian?))) (define-constant %simple-operation-length 5) ;;; This is temporary, until ^super is open coded directly. (define-constant %^super-tail (add-method ((make-open-coded-operation '((^super-tail)) 3 1) (object) the-type the-op self) (error "Non-open-coded call to %^super-tail."))) ;;; eof oaklisp-1.3.3.orig/src/world/mac-compiler3.oak0000664000175000000620000003525507725515165020155 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;;; Copyright (C) 1986 Kevin J. Lang and Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; do some constant folding when appropriate ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;some of these use eq? get-type instead of is-a? (define-instance fold-constants-v operation) (add-method (fold-constants-v (ast-node) self locale) (map-ast-with-arg! self fold-constants-v locale)) (add-method (fold-constants-v (ast-variable-node var-type name) self locale) ; (format #t "folding ... ~a ~a ~%" self locale) (if (and (eq? var-type 'global) (variable? locale name) (frozen? locale name)) (let ((new-node (addedcode->ast `(quote ,(contents (variable? locale name))) self))) (set! (constn-name new-node) name) (set! (constn-origin new-node) self) new-node) self)) (let ((constant-pred (lambda (x) (eq? ast-constant-node (get-type x))))) (add-method (fold-constants-v (ast-combination-node op args rest-name) self locale) (map-ast-with-arg! self fold-constants-v locale) (cond ((and (every? constant-pred (cons op args)) (side-effect-free? (constn-value op)) (eq? nichevo rest-name)) (catch-errors (general-error (lambda (err) (format standard-error "~&Error applying ~S to ~S while constant folding ignored.~%" (constn-value op) (map constn-value args)) (report err standard-error) self) (lambda (result) (let ((new-node (addedcode->ast `(quote ,result) self))) (set! (constn-name new-node) 'folded) (set! (constn-origin new-node) self) new-node))) (apply (constn-value op) (map constn-value args)))) (else self)))) (add-method (fold-constants-v (ast-if-node predicate consequent alternate) self locale) (map-ast-with-arg! self fold-constants-v locale) (if (eq? ast-constant-node (get-type predicate)) (if (constn-value predicate) consequent alternate) self)) (add-method (fold-constants-v (ast-method-node ivarlist ivarmap primitivep method-type status arglist body) self locale) (map-ast-with-arg! self fold-constants-v locale) (set! ivarmap '()) (when ivarlist (cond ((ivar-heuristic method-type ivarlist locale) => (lambda (heurmap) (set! ivarmap heurmap))) (primitivep (error "Couldn't generate heuristic map for ~S~%" (listify self))) (else (set! ivarmap ivarlist)))) (cond ((and (eq? 'inline status) (= 1 (length arglist)) (eq? ast-variable-node (get-type body)) (eq? self (varn-source-contour body))) (let ((new-node (addedcode->ast `(quote ,identity) self))) (set! (constn-name new-node) 'identity) new-node)) (else self))) ;The next two methods insure that no frozen substitutions ;will occur in l-value positions. (add-method (fold-constants-v (ast-set-node expression) self locale) (set! expression (fold-constants-v expression locale)) self) (add-method (fold-constants-v (ast-make-locative-node) self locale) self) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; attempt to determine the ivar map ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;The true layout of the ivars in the type for which a method is being compiled ;cannot be determined until load-time. However, the following heuristic ;guesses the layout and the rest of the compilation proceeds accordingly. ;The code object which is produced has a slot which contains the presumed ;ivar map. When the loader calls the %install-method routine, the guess ;is compared with the correct map, and the code is patched if necessary. (define-instance ivar-heuristic operation) (add-method (ivar-heuristic (object) self ivarlist locale) nil) (add-method (ivar-heuristic (ast-variable-node var-type name) self ivarlist locale) (and (eq? var-type 'global) (let ((v (variable? locale name))) (and v (ivar-heuristic (contents v) ivarlist locale))))) (add-method (ivar-heuristic (ast-constant-node value) self ivarlist locale) (ivar-heuristic value ivarlist locale)) (add-method (ivar-heuristic (type ivar-list) self ivarlist locale) (if (subset? ivarlist ivar-list) (munch-together ivarlist ivar-list) #f)) (define (munch-together ivarlist ivar-list) ;; ivarlist is the requested one, ivar-list the real one. (cond ((null? ivar-list) '()) ((memq (car ivar-list) ivarlist) (cons (car ivar-list) (munch-together ivarlist (cdr ivar-list)))) (else (let ((x (munch-together ivarlist (cdr ivar-list)))) (if (not (null? x)) (cons #f x) '()))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (guarded-value-probe thing required-type accessor value) (and (is-a? thing required-type) (eq? value (accessor thing)))) ;This predicate only works after constant folding has occurred, or if ;lambda is macro expanded with make, operation, etc., inserted as constants. (define-instance am-I-a-lambda? operation) (add-method (am-I-a-lambda? (ast-method-node op ivarlist method-type) self) (and (null? ivarlist) (and (is-a? op ast-combination-node) (guarded-value-probe (combn-op op) ast-constant-node constn-value make) (= 1 (length (combn-args op))) (guarded-value-probe (car (combn-args op)) ast-constant-node constn-value operation)) (guarded-value-probe method-type ast-constant-node constn-value object))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; add code to generate closures ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;This operation inserts the code that makes closures and methods ;at run time. The method node is left in the tree, but ;its status is downgraded from 'method to 'code. ;After this point in the compilation, it is no longer necessary to ;mess around with the op and method-type fields in method nodes, ;so for efficiency, they are erased. ;the following open-codable operations must be defined in flat-compiler-locale ; _%install-method-with-env, %make-closed-environment, %make-cell (define-instance insert-method-maker-v operation) (add-method (insert-method-maker-v (ast-node) self) (map-ast! self insert-method-maker-v)) (add-method (insert-method-maker-v (ast-method-node status op method-type body primitivep) self) (let ((envlist (contn-envlist self))) (map-ast! self insert-method-maker-v) (cond ((eq? status 'method) (set! status 'code) (let* ((lambda-p (am-I-a-lambda? self)) (wrapping (if primitivep (addedcode->ast `(,_%install-method-with-env ,method-type ,op ,self ,(if envlist `(,%make-closed-environment ,@(map (lambda (x) `(%make-locative ,x)) envlist)) `%empty-environment)) self) (addedcode->ast (splice (list (list (if lambda-p ; (if envlist '%install-lambda-with-env '%install-lambda) %make-lambda-with-env ; (if envlist '%install-method-with-env '%install-method) '%install-method-with-env )) (if lambda-p '() (list method-type)) (if lambda-p '() (list op)) (list self) (if envlist (list `(,%make-closed-environment ,@(map (lambda (x) `(%make-locative ,x)) envlist))) (list `%empty-environment) ; '() ))) self)))) (classify-variables wrapping) (set! op nichevo) ;these have been plugged (set! method-type nichevo) ;into the wrapping wrapping)) (else (set! op nichevo) (set! method-type nichevo) self)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; compile heap variables ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;sequencer for heap variable operations (define-instance heapify-variables-v operation) (add-method (heapify-variables-v (ast-node) astree) (determine-heap-vars astree) (set! astree (indirect-to-heap-v astree)) (set! astree (fold-contents-v astree)) (insert-heap-prologue astree) astree) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;Stack variables must be moved to the heap if they are closed ;over or locatives are made to them. This operation records ;in the heaplist field of a method which of its arguments must ;be moved to the heap. Checking for %MAKE-LOCATIVEs suffices ;to find closed-over variables, since the closure-building code ;already inserted generates locatives to such variables. (define-instance determine-heap-vars operation) (with-operations (you-are-being-located) (add-method (determine-heap-vars (ast-node) self) (walk-ast self determine-heap-vars)) (add-method (determine-heap-vars (ast-method-node heaplist) self) (set! heaplist '()) (walk-ast self determine-heap-vars)) (add-method (determine-heap-vars (ast-make-locative-node variable) self) (you-are-being-located variable)) (add-method (you-are-being-located (ast-variable-node name var-type source-contour) self) (if (eq? var-type 'stack) (set! (heap? source-contour name) t)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;This operation replaces references to environment, heap, and ;global variables with indirect references. (define-instance indirect-to-heap-v operation) (add-method (indirect-to-heap-v (ast-node ) self) (map-ast! self indirect-to-heap-v)) (add-method (indirect-to-heap-v (ast-variable-node var-type name source-contour) self) (if (or (eq? var-type 'evar) (eq? var-type 'global) (and (eq? var-type 'stack) (heap? source-contour name))) (addedcode->ast (list contents self) self) self)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;This operation folds (%set (contents x) y) to ((setter contents) x y) ;and (%make-locative (contents x)) to x. ;This is necessary because indirect-to-heap-v inserts indirections ;after the macro expansion phase. ;;; Hey, Kevin, since %SET is no longer in the language, could this pass ;;; be flushed? (define-instance fold-contents-v operation) (add-method (fold-contents-v (ast-node) self) (map-ast! self fold-contents-v)) (labels (((contents-node? node) (and (is-a? node ast-combination-node) (is-a? (combn-op node) ast-constant-node) (eq? contents (constn-value (combn-op node)))))) (add-method (fold-contents-v (ast-set-node variable expression) self) (map-ast! self fold-contents-v) (if (contents-node? variable) (addedcode->ast (list (setter contents) (car (combn-args variable)) expression) self) self)) (add-method (fold-contents-v (ast-make-locative-node variable) self) (map-ast! self fold-contents-v) (if (contents-node? variable) (car (combn-args variable)) self))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;This operation adds to a method the prologue code ;for moving arguments from the stack to the heap. (define-instance insert-heap-prologue operation) (add-method (insert-heap-prologue (ast-node) self) (walk-ast self insert-heap-prologue)) (add-method (insert-heap-prologue (ast-method-node heaplist body) self) (walk-ast self insert-heap-prologue) (when heaplist (if (not (is-a? body ast-block-node)) (set! body (addedcode->ast `(%block ,body) body))) (let ((prologue (map (lambda (var) (addedcode->ast `(%set ,var (,%make-cell ,var)) body)) heaplist))) (for-each classify-variables prologue) (set! (blkn-body body) (append prologue (blkn-body body)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; determine the stack map at every node ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The stack-map slot of a node contains a map of the stack at the ;;; moment the code for that node executes. These maps have the ;;; format '(a b c 0 0 d e f), where a is the variable on the top of ;;; the stack, and the zeros represent anonymous junk from the point ;;; of view of the node. ;;; Note: the following code assumes that every form leaves exactly ;;; one result on the stack. (define-instance stash-stack-map operation) (with-operations (proceed) (add-method (stash-stack-map (ast-node stack-map) self outer-map) (set! stack-map outer-map) (proceed self outer-map)) (add-method (proceed (ast-node stack-map) self outer-map) (walk-ast-with-arg self stash-stack-map outer-map)) (add-method (proceed (ast-method-node arglist body status inlabels?) self outer-map) ;beware hack: if it's a real inline lambda , (a b)+(0 0 x y)->(a b x y) ; but if it's in a labels, (a b)+(x y)->(a b x y) (let ((newmap (if (eq? status 'inline) (append arglist (if inlabels? outer-map (tail outer-map (length arglist)))) arglist))) (stash-stack-map body newmap))) (add-method (proceed (ast-set-node variable expression) self outer-map) (stash-stack-map expression outer-map) (stash-stack-map variable (cons 0 outer-map))) (add-method (proceed (ast-combination-node op args rest-name) self outer-map) (let ((backwards? (and (is-a? op ast-constant-node) (is-a? (constn-value op) open-coded-mixin) (is-a? (constn-value op) backwards-args-mixin) (eq? rest-name nichevo)))) (iterate step ((stack-map outer-map) (arglist (if backwards? args (reverse args)))) (cond ((null? arglist) (stash-stack-map op stack-map) (or (eq? rest-name nichevo) (stash-stack-map rest-name (cons 0 stack-map)))) (else (stash-stack-map (car arglist) stack-map) (step (cons 0 stack-map) (cdr arglist)))))))) (set! nichevo (make ast-node)) oaklisp-1.3.3.orig/src/world/signal.oak0000664000175000000620000002536507725515165017000 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Barak A. Pearlmutter and Kevin J. Lang ;;; This file defines the error system, which is based on error types ;;; and objects and signaling them, similar to the ZetaLisp mechanisms. ;;; When an error occurs the appropriate type of error object is ;;; created, then the appropriate message to send to that guy is ;;; looked up on the #*error-handlers list, and then that ;;; message is sent to the error tail recursively, so if the method ;;; for that returns a value that's what the signal call returns. ;;; This is an alist of error types and operations. (set! #*error-handlers '()) (define-instance condition type '(continuation) '()) (define-instance general-error type '() (list condition)) (add-method (initialize (condition continuation) self) (set! continuation #f) self) (define-instance proceedable-mixin type '(message) '()) (add-method (initialize (proceedable-mixin message) self the-mess) (set! message the-mess) self) (define-instance proceedable-error type '() (list proceedable-mixin general-error)) (add-method (initialize (proceedable-error) self the-mess) (^super proceedable-mixin initialize self the-mess) (^super general-error initialize self)) (define-instance proceedable-condition type '() (list proceedable-mixin condition)) (add-method (initialize (proceedable-condition) self the-mess) (^super proceedable-mixin initialize self the-mess) (^super condition initialize self)) ;;; Call remember-context on an error with an argument that takes the error ;;; and stashes it away somewhere, and then returns to the nearest top ;;; level or something like that. You can look at the error object, ask ;;; it to report, and stuff like that; but if you call invoke-debugger or ;;; proceed on it, it will bop into the error context and then do it. (define-instance remember-context operation) (add-method (remember-context (condition continuation) self after) (when continuation (error "Context already stored for this error.")) (let ((op (call/cc (lambda (k) (set! continuation k) (after self) (error "The arg to remember-context returned."))))) (set! continuation #f) (op self))) ;;; (define-instance invoke-in-error-context operation) (add-method (invoke-in-error-context (condition continuation) self op) (if continuation (continuation op) (op self))) ;;; Invoke the debugger at the given error. (define-instance invoke-debugger operation) ;;; Write a description of the error to the given stream. Return the ;;; description as a string if passed nil. (define-instance report operation) (add-method (invoke-debugger (condition continuation) self) (invoke-in-error-context self really-invoke-debugger)) ;;; (define-instance really-invoke-debugger operation) (define nested-error-limit 20) (add-method (really-invoke-debugger (condition) self) (bind ((#*debug-level (+ #*debug-level 1))) (when (and nested-error-limit (> #*debug-level nested-error-limit)) (exit 1 "Too many nested debuggers!~%")) (format standard-error "~&Error: ") (report self standard-error) (read-eval-print-loop))) (add-method (really-invoke-debugger (proceedable-mixin message) self) (error-return message (^super condition really-invoke-debugger self))) ;;; This is what to do with an error that has no other handler. (push #*error-handlers (cons general-error invoke-debugger)) ;;; Some errors can be proceeded from. (define-instance proceed operation) (add-method (proceed (proceedable-error) self value) (invoke-in-error-context self (lambda (self) value))) ;;; This is the big interface: signal. (let ((signal-aux (lambda (args) (destructure (error-type . args) args (let ((the-error (apply make error-type args))) (iterate aux ((l #*error-handlers)) (cond ((null? l) ;; No handler found, ignore the signal. #f) ((subtype? error-type (caar l)) ;; Found one, invoke it. ((cdar l) the-error)) (else ;; Keep looking. (aux (cdr l)))))))))) (define (signal error-type . args) (listify-args signal-aux error-type . args))) ;;; The error type to signal when something that isn't an operation is ;;; called as if it were one. (define-instance not-an-operation type '(op arglist) (list proceedable-error object)) (add-method (initialize (not-an-operation op arglist) self the-op the-arglist) (set! op the-op) (set! arglist the-arglist) (^super proceedable-error initialize self (format #f "Return a value from the call to ~S." the-op))) (add-method (report (not-an-operation op arglist) self stream) (let ((count (length arglist))) (format stream "call to ~S, which isn't an operation, with ~D arg~P" op count count) (when arglist (format stream ": ")) (print-comma-separated-list arglist stream) (format stream ".~%"))) (add-method (really-invoke-debugger (not-an-operation op arglist) self) (^super proceedable-error really-invoke-debugger self)) ;;; The error type to signal when an operation on some object has no ;;; handler. (define-instance operation-not-found type '(op arglist) (list proceedable-error object)) (add-method (initialize (operation-not-found op arglist) self the-op the-arglist) (set! op the-op) (set! arglist the-arglist) (^super proceedable-error initialize self (format #f "Return a value from the call to ~S." the-op))) (add-method (report (operation-not-found op arglist) self stream) (let ((count (length arglist))) (format stream "no method for ~S with ~D arg~P" op count count) (when arglist (format stream ": ")) (print-comma-separated-list arglist stream) (format stream ".~%"))) (add-method (really-invoke-debugger (operation-not-found op arglist) self) ;; I'm a little dubious about this code: (native-catch return-value (error-return (format #f "Retry applying ~A to ~S." op arglist) (throw return-value (^super proceedable-error really-invoke-debugger self))) (apply op arglist))) ;;; The error type to signal when an operation on some object has no ;;; handler when called using ^super. (define-instance ^super-not-found type '(typ op arglist) (list proceedable-error object)) (add-method (initialize (^super-not-found typ op arglist) self the-typ the-op the-arglist) (set! typ the-typ) (set! op the-op) (set! arglist the-arglist) (^super proceedable-error initialize self (format #f "Return a value from the call to ~S." the-op))) (add-method (report (^super-not-found typ op arglist) self stream) (let ((count (length arglist))) (format stream "no ^SUPER method above ~S for ~S with ~D arg~P" typ op count count) (when arglist (format stream ": ")) (print-comma-separated-list arglist stream) (format stream ".~%"))) (add-method (really-invoke-debugger (^super-not-found typ op arglist) self) ;; I'm a little dubious about this code: (native-catch return-value (error-return (format #f "Retry applying ^SUPER ~S ~A to ~S." typ op arglist) (throw return-value (^super proceedable-error really-invoke-debugger self))) (apply ^super typ op arglist))) ;;; Similarly, something to signal when you get the incorrect number ;;; of arguments: (define-instance nargs-error type '(op args wanted) (list proceedable-error)) (add-method (initialize (nargs-error op args wanted) self top targs twanted) (set! op top) (set! args targs) (set! wanted twanted) (^super proceedable-error initialize self (format #f "Return a value from the call to ~S." op))) (add-method (report (nargs-error op args wanted) self stream) (format stream "~D argument~P required by ~A, ~D received" wanted wanted op (length args)) (when args (format stream ": ")) (print-comma-separated-list args stream) (format stream ".~%")) (add-method (really-invoke-debugger (nargs-error op args) self) (native-catch return-value (error-return (format #f "Retry applying ~A to ~S." op args) (throw return-value (^super proceedable-error really-invoke-debugger self))) (apply op args))) (define-instance nargs-exact-error type '() (list nargs-error object)) (define-instance nargs-gte-error type '() (list nargs-error object)) (add-method (report (nargs-gte-error) self stream) (format stream "at least ") (^super nargs-error report self stream)) ;;; Maybe this should really go in format.oak and some control directive ;;; should use it? (define (print-comma-separated-list l stream) (cond ((null? l)) ((null? (cdr l)) (format stream "~S" (car l))) (else (format stream "~S, " (car l)) (print-comma-separated-list (cdr l) stream)))) ;;; The ERROR function: (define (error format-string . format-args) (signal generic-fatal-error format-string . format-args)) (define-instance generic-fatal-error type '(message) (list general-error object)) (add-method (initialize (generic-fatal-error message) self format-string . args) (listify-args (lambda (args) (set! message (apply format nil format-string args)) (^super general-error initialize self)) . args)) (add-method (report (generic-fatal-error message) self stream) (write-string message stream)) ;;; The CERROR function: (define (cerror format-string . format-args) (signal generic-proceedable-error format-string . format-args)) (define-instance generic-proceedable-error type '(message) (list proceedable-error object)) (add-method (initialize (generic-proceedable-error message) self proceed-message format-string . args) (listify-args (lambda (args) (set! message (apply format nil format-string args)) (^super proceedable-error initialize self proceed-message)) . args)) (add-method (report (generic-proceedable-error message) self stream) (cond ((not stream) message) (else (write-string message stream)))) ;;; Something to signal whenever an infinite loop is encountered. (define-instance infinite-loop type '() (list generic-fatal-error)) (add-method (initialize (infinite-loop) self) (^super generic-fatal-error initialize self "infinite loop encountered.")) ;;; eof oaklisp-1.3.3.orig/src/world/file-errors.oak0000664000175000000620000000511107725515165017737 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang ;;; Define some error types to signal when file system stuff fails. Below, ;;; fs is used as an abbreviation for file system. (define-instance fs-error type '() (list general-error)) (define-instance proceedable-fs-error type '() (list proceedable-error fs-error)) (define-instance error-opening type '(name) (list proceedable-fs-error)) (define-instance error-opening-read type '() (list error-opening object)) (define-instance error-opening-write type '() (list error-opening object)) (define-instance error-opening-append type '() (list error-opening object)) (add-method (initialize (error-opening name) self filename) (set! name filename) (^super proceedable-fs-error initialize self (format #f "Supply a file to ~A instead (none to retry \"~A\")." (what-attempting self) filename))) (add-method (report (error-opening name) self stream) (format stream "Unable to open ~S for ~A access.~%" name (what-attempting self))) ;;; If passed no new filename return the old one. (add-method (really-invoke-debugger (error-opening name) self) (or (^super proceedable-fs-error really-invoke-debugger self) name)) (define-instance what-attempting operation) (add-method (what-attempting (error-opening-read) self) 'read) (add-method (what-attempting (error-opening-write) self) 'write) (add-method (what-attempting (error-opening-append) self) 'append) (define-instance error-changing-directory type '(name) (list proceedable-fs-error object)) (add-method (initialize (error-changing-directory name) self filename) (set! name filename) (^super proceedable-fs-error initialize self (format #f "Supply a directory to change to (none to retry \"~A\")." filename))) (add-method (report (error-changing-directory name) self stream) (format stream "Unable to change to directory \"~A\".~%" name)) ;;; eof oaklisp-1.3.3.orig/src/world/lazy-cons.oak0000664000175000000620000000573007725515165017434 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1888 Kevin J. Lang & Barak A. Pearlmutter (define-instance lazy-cons type '(car-thunk cdr-thunk car-flag cdr-flag) (list pair object)) (add-method (initialize (lazy-cons car-thunk cdr-thunk car-flag cdr-flag) self new-car-thunk new-cdr-thunk) (set! car-thunk new-car-thunk) (set! cdr-thunk new-cdr-thunk) (set! car-flag nil) (set! cdr-flag nil) self) (add-method (car (lazy-cons car-thunk car-flag) self) (if car-flag car-thunk (let ((newcar (car-thunk))) ;; Critical section; would be a good idea to disable interrupts. (set! car-flag #t) (set! car-thunk newcar)))) (add-method (cdr (lazy-cons cdr-thunk cdr-flag) self) (if cdr-flag cdr-thunk (let ((newcdr (cdr-thunk))) ;; Critical section; would be a good idea to disable interrupts. (set! cdr-flag #t) (set! cdr-thunk newcdr)))) (add-method ((setter car) (lazy-cons car-thunk car-flag) self val) (set! car-flag #t) (set! car-thunk val)) (add-method ((setter cdr) (lazy-cons cdr-thunk cdr-flag) self val) (set! cdr-flag #t) (set! cdr-thunk val)) (add-method ((locater car) (lazy-cons car-thunk) self) (car self) (make-locative car-thunk)) (add-method ((locater cdr) (lazy-cons cdr-thunk) self) (cdr self) (make-locative cdr-thunk)) (define-syntax (lcons a d) `(make lazy-cons (lambda () ,a) (lambda () ,d))) (define-instance lmap operation) (add-method (lmap (operation) op l) (if (null? l) '() (lcons (op (car l)) (lmap op (cdr l))))) (define (square-list n) (make lazy-cons (lambda () (* n n)) (lambda () (square-list (+ n 1))))) (define (integer-list n) (make lazy-cons (lambda () n) (lambda () (integer-list (+ n 1))))) (define (fair-merge l1 l2) (if (not (null? l1)) (lcons (car l1) (fair-merge l2 (cdr l1))) l2)) ;;; This print method isn't really necessary: (add-method (print (lazy-cons car-thunk cdr-thunk car-flag cdr-flag) self s) (let ((f #*forcible-print-magic)) (cond ((eq? f 'transparent) (^super pair print self s)) ((eq? f '#f) (format s "#[LAZY-CONS ~A ~A ~!]" (if car-flag car-thunk "?") (if cdr-flag cdr-thunk "?") self)) ((eq? f 'indicate) (format s "#L") (^super pair print self s)) (else (error "Unknow (FLUID FORCIBLE-PRINT-MAGIC) option ~S." f))))) ;;; eof oaklisp-1.3.3.orig/src/world/ops.oak0000664000175000000620000000271007725515165016311 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;;; Copyright (C) 1987 Kevin J. Lang and Barak A. Pearlmutter ;;; make some operations before their definition files (define-instance print operation) (define-instance fill! operation) (define-instance equal? operation) (define-instance reverse operation) (define-instance reverse! operation) (define-instance copy operation) (define-instance remove operation) (define-instance remove-if operation) (define-instance subseq operation) (define-instance subsequence? operation) (define-constant-instance length settable-operation) (define-constant-instance nth locatable-operation) (define-constant-instance present? locatable-operation) ;early error messages shouldn't die. (add-method (print (object) self stream) (write-char stream #\&)) ;;; eof oaklisp-1.3.3.orig/src/world/random.oak0000664000175000000620000000233507725515165016773 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 2002, Barak A. Pearlmutter ;;; Modified from code by Troy Ross (define random-device "/dev/urandom") (define random-device-stream #f) (define random256 (lambda () (unless random-device-stream (set! random-device-stream (open-input-file random-device))) (#^number (read-char random-device-stream)))) ;;; (define random259200 ;;; (let ((rand-seed 444)) ;;; (lambda () ;;; (set! rand-seed (modulo (+ 54773 (* 7141 rand-seed)) 259200)) ;;; rand-seed))) oaklisp-1.3.3.orig/src/world/anonymous.oak0000664000175000000620000001134507725515165017544 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter (set! #*fancy-references #f) (define expression-table (make-eq-hash-table)) (define (reasonable-expression a-locale obj) (let ((ref (present? expression-table obj))) (cond ((and ref (let* ((expr (cdr ref)) (curval (dumb-but-safe-eval expr a-locale))) (if (eq? obj curval) expr nil))) => identity) (else (let ((expr (create-accessor-expression a-locale obj))) (cond (ref (set! (cdr ref) expr)) (else (set! (present? expression-table obj) expr) expr))))))) (define-instance create-accessor-expression operation) (add-method (create-accessor-expression (locale variable-table superiors) self value) (native-catch done (block (for-each-r variable-table (lambda (sym cell) (let ((guy (contents cell))) (when (eq? guy value) (throw done sym)) (let ((try (create-compound-accessor-expression self guy value))) (when try (throw done try)))))) (any? (lambda (sup) (create-accessor-expression sup value)) superiors)))) (define (create-compound-accessor-expression locale guy value) (let ((getter (could-you-get-this-value? guy value))) (and getter (let ((expr (map (lambda (z) (reasonable-expression locale z)) getter))) (and (not (any? null? expr)) expr))))) (set! fancy-accessor-guards '()) (set! fancy-accessor-operations '()) (define (could-you-get-this-value? guy val) (iterate next ((guards fancy-accessor-guards)(ops fancy-accessor-operations)) (cond ((null? guards) nil) ((and ((car guards) guy) (eq? ((car ops) guy) val)) (list (car ops) guy)) (else (next (cdr guards)(cdr ops)))))) (define (how-to-get-val ag ao) (push fancy-accessor-guards ag) (push fancy-accessor-operations ao)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;Here is the extension mechanism. (how-to-get-val (lambda (x) (is-a? x coercable-type)) coercer) (how-to-get-val (lambda (x) (is-a? x settable-operation)) setter) (how-to-get-val (lambda (x) (is-a? x locatable-operation)) locater) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (dumb-but-safe-eval expr locale) (cond ((and (symbol? expr) (variable? locale expr)) => contents) ((is-a? expr self-evaluatory-mixin) expr) ((pair? expr) (let ((evexpr (map (lambda (x) (dumb-but-safe-eval x locale)) expr))) (if (and (>= (length evexpr) 2) (is-a? (first evexpr) operation) (got-a-method? (get-type (second evexpr)) (first evexpr))) (apply (first evexpr) (cdr evexpr)) nil))) (else nil))) (define-instance got-a-method? operation) (add-method (got-a-method? (type supertype-list operation-method-alist) ty op) (or (assq op operation-method-alist) (%get-an-ivar operation op 'lambda?) (any? (lambda (t) (got-a-method? t op)) supertype-list))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;Here is the old version of this. #| (define reference-table (make-eq-hash-table)) (define (reasonable-expression a-locale obj) (if (eq? #*fancy-references 'really-fancy) (accessor-expression a-locale obj) (let ((ref (present? reference-table obj))) (cond ((and ref (let* ((expr (cdr ref)) (loc (variable? a-locale expr))) (cond ((and loc (eq? obj (contents loc))) expr) (else nil)))) => identity) (else (let ((expr (create-reasonable-expression a-locale obj))) (cond (ref (set! (cdr ref) expr)) (else (set! (present? reference-table obj) expr) expr)))))))) (define (create-reasonable-expression a-locale obj) (let ((vars (bound-var-list a-locale obj))) (cond (vars (car vars)) (else nil)))) (define-instance bound-var-list operation) (add-method (bound-var-list (locale variable-table) self val) (let ((vars '())) (for-each-r variable-table (lambda (sym cell) (when (eq? (contents cell) val) (set! vars (cons sym vars))))) vars)) |# oaklisp-1.3.3.orig/src/world/streams.oak0000664000175000000620000002515607725515165017177 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Barak A. Pearlmutter&Kevin J. Lang ;;; Generic streams, and specific ones for file and terminal I/O. (define-instance stream type '() '()) (define-instance input-stream type '(peek-buff) (list stream)) (add-method (initialize (input-stream peek-buff) self) (set! peek-buff #f) self) ;;; INPUT-STREAM is an abstract type that defines these: (define-instance read-char operation) (define-instance unread-char operation) (define-instance peek-char operation) ;;; In terms of this: (define-instance really-read-char operation) ;;; Like this: (add-method (read-char (input-stream peek-buff) self) (if peek-buff (block0 peek-buff (set! peek-buff #f)) (really-read-char self))) (add-method (unread-char (input-stream peek-buff) self c) (if peek-buff (error "Can't unread two characters.") (set! peek-buff c))) (add-method (peek-char (input-stream peek-buff) self) (or peek-buff (set! peek-buff (really-read-char self)))) ;;; For internal use only, something to check if there is a char in the ;;; unread buffer. (define-instance unread-chars settable-operation) (add-method (unread-chars (input-stream peek-buff) self) (if peek-buff 1 0)) (add-method ((setter unread-chars) (input-stream peek-buff) self val) (unless (zero? val) (cerror "Proceed." "can only set UNREAD-CHARS to 0, not ~D." val)) (set! peek-buff #f)) ;;; OUTPUT-STREAM is similar, but doesn't have to do any of that stuff. (define-instance output-stream type '() (list stream)) (define-instance write-char operation) ;;; Define a distinguished object, the-eof-token. (define-instance eof-token type '() (list object)) (define-simple-print-method eof-token "EOF") (define-instance the-eof-token eof-token) ;;; How to do carriage returns without typing #\newline, which is ugly: (define-instance newline operation) (define-instance freshline operation) ;;; If nothing better is known, a freshline request must do a newline: (add-method (freshline (output-stream) self) (newline self)) (add-method (newline (output-stream) self) (write-char self #\NEWLINE)) ;;; Make (format s "~&") work for selected streams: (define-instance freshline-hacking-mixin type '(on-a-new-line) (list)) (add-method (initialize (freshline-hacking-mixin on-a-new-line) self) (set! on-a-new-line #t) self) (add-method (freshline (freshline-hacking-mixin on-a-new-line) self) (unless on-a-new-line (write-char self #\NEWLINE))) (add-method (write-char (freshline-hacking-mixin on-a-new-line) self char) (set! on-a-new-line (eq? char #\NEWLINE))) ;;; UNIX file descriptor I/O: ;;; Define our primitives. ;;; The STREAM-PRIMITIVE opcode is here for your OS dependent pleasure. ;;; UNIX dependent in this case. (define-constant-instance %stream-primitive (mix-types oc-mixer (list foldable-mixin operation))) (let ((sp-alist '())) (add-method (%stream-primitive (object) n) (let ((x (assq n sp-alist))) (cond (x => cdr) (else (let ((op (make (mix-types oc-mixer (list open-coded-mixin operation)) `((stream-primitive ,n)) (nth '(0 0 0 2 2 2 1 1 2 1 1 1 2 2) n) 1))) (set! sp-alist (cons (cons n op) sp-alist)) op)))))) #|| ;;; This is what all the stream primitives do: ;;; The number of arguments is listed in the list passed to nth above. (define (get-stdin) ((%stream-primitive 0))) (define (get-stdout) ((%stream-primitive 1))) (define (get-stderr) ((%stream-primitive 2))) (define (fopen-read string-loc len) ((%stream-primitive 3) string-loc len)) (define (fopen-write string-loc len) ((%stream-primitive 4) string-loc len)) (define (fopen-append string-loc len) ((%stream-primitive 5) string-loc len)) (define (fclose fd) ((%stream-primitive 6) fd)) (define (fflush fd) ((%stream-primitive 7) fd)) (define (putc fd char) ((%stream-primitive 8) fd char)) (define (getc fd) ((%stream-primitive 9) fd)) (define (interactive? fd) ((%stream-primitive 10) fd)) (define (ftell fd) ((%stream-primitive 11) fd)) (define (fseek fd position) ((%stream-primitive 12) fd position)) (define (chdir string-loc len) ((%stream-primitive 13) string-loc len)) ||# ;;; Streams that go to Unix file descriptors: (define-instance file-stream type '(fd) '()) (add-method (initialize (file-stream fd) self the-fd) (set! fd the-fd) self) (define-instance file-input-stream type '() (list file-stream input-stream object)) (define-instance file-output-stream type '() (list freshline-hacking-mixin file-stream output-stream object)) (add-method (initialize (file-input-stream) self the-fd) (^super file-stream initialize self the-fd) (^super input-stream initialize self)) (add-method (initialize (file-output-stream) self the-fd) (^super freshline-hacking-mixin initialize self) (^super file-stream initialize self the-fd)) (add-method (write-char (file-output-stream) self char) (^super freshline-hacking-mixin write-char self char) (^super file-stream write-char self char)) ;;; For use in writing .oa files and similar stuff that never gets freshline ;;; messages because it's not for people to read: (define-instance ugly-file-output-stream type '() (list file-stream output-stream object)) ;;; (define-instance open-input-file operation) (define-instance open-output-file operation) (define-instance open-output-file-append operation) (define-instance open-output-file-ugly operation) (define-instance open-output-file-append-ugly operation) (add-method (open-input-file (string) self) (iterate aux ((filename self)) (let ((the-fd ((%stream-primitive 3) (make-locative (%vref filename 0)) (length filename)))) (cond ((not the-fd) (aux (signal error-opening-read filename))) (else (make file-input-stream the-fd)))))) (add-method (open-output-file (string) self) (iterate aux ((filename self)) (let ((the-fd ((%stream-primitive 4) (make-locative (%vref filename 0)) (length filename)))) (cond ((not the-fd) (aux (signal error-opening-write filename))) (else (make file-output-stream the-fd)))))) (add-method (open-output-file-append (string) self) (iterate aux ((filename self)) (let ((the-fd ((%stream-primitive 5) (make-locative (%vref filename 0)) (length filename)))) (cond ((not the-fd) (aux (signal error-opening-append filename))) (else (make file-output-stream the-fd)))))) (add-method (open-output-file-ugly (string) self) (iterate aux ((filename self)) (let ((the-fd ((%stream-primitive 4) (make-locative (%vref filename 0)) (length filename)))) (cond ((not the-fd) (aux (signal error-opening-write filename))) (else (make ugly-file-output-stream the-fd)))))) (add-method (open-output-file-append-ugly (string) self) (iterate aux ((filename self)) (let ((the-fd ((%stream-primitive 5) (make-locative (%vref filename 0)) (length filename)))) (cond ((not the-fd) (aux (signal error-opening-append filename))) (else (make ugly-file-output-stream the-fd)))))) (add-method (really-read-char (file-stream fd) self) (or ((%stream-primitive 9) fd) the-eof-token)) (add-method (write-char (file-stream fd) self char) ;; Note: this returns #t on success, #f on failure: ((%stream-primitive 8) fd char)) ;;;;;;;;;;;; (define-instance close operation) (define-instance flush operation) (add-method (close (file-stream fd) self) (cond ((null? fd) (cerror "Proceed." "attempt to close ~S, which is already closed." self)) (((%stream-primitive 6) fd) (set! fd nil)) (else (cerror "Ignore the problem." "couldn't close ~S." self)))) (add-method (flush (file-stream fd) self) (cond ((null? fd) (cerror "Proceed." "attempt to flush ~S, which is closed." self)) ((null? ((%stream-primitive 7) fd)) (cerror "Ignore the problem." "error flushing ~S." self)) (else nil))) (define-instance interactive? operation) (add-method (interactive? (file-stream fd) self) ((%stream-primitive 10) fd)) (add-method (interactive? (stream) self) nil) ;;; Position returns the current position of the "read head" in a file (define-instance position settable-operation) (add-method (position (file-stream fd) self) ((%stream-primitive 11) fd)) (add-method (position (file-input-stream) self) (- (^super file-stream position self) (unread-chars self))) (add-method ((setter position) (file-stream fd) self pos) (unless ((%stream-primitive 12) fd pos) (cerror "Proceed." "unable to set the position of ~A to ~D." self pos)) pos) (add-method ((setter position) (file-input-stream) self pos) ;; Clear out any unread characters: (set! (unread-chars self) 0) (^super file-stream (setter position) self pos)) ;;; The current working directory. Settable. Currently does not use a ;;; primitive to try to figure it out for real, but just remembers. (define-instance cwd settable-operation) (let ((the-cwd #f)) (add-method (cwd (object)) the-cwd) (add-method ((setter cwd) (string) self) (iterate aux ((filename self)) (cond (((%stream-primitive 13) (make-locative (%vref filename 0)) (length filename)) (set! the-cwd filename) #t) (else (aux (signal error-changing-directory filename))))))) ;;; define this as a no op for now; used in top-level, so it has to be ;;; in the cold world, but backspace hacking streams use continuations ;;; so we don't want them in the cold world load. (define-instance clear-backspace-buffer operation) (add-method (clear-backspace-buffer (input-stream) self) #f) ;;; SETUP-STANDARD-STREAMS should be called at warm boot time. (define (setup-standard-streams) (set! standard-input (make file-input-stream ((%stream-primitive 0)))) (set! standard-output (make file-output-stream ((%stream-primitive 1)))) ;; Stop buffer skew from desyncing error messages: ;; (set! standard-error (make file-output-stream ((%stream-primitive 2)))) (set! standard-error standard-output) #f) (add-warm-boot-action setup-standard-streams) ;;; eof oaklisp-1.3.3.orig/src/world/freeze.oak0000664000175000000620000000254407725515165016775 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;; The locale structure looks like this: ;; ;; SYSTEM ;; / \ ;; COMPILER SYSTEM-INTERNALS ;; / \ ;; SCRATCH COMPILER-INTERNALS ;; ;; System-locale gets filled in from the boot world by patch-locales.oak. (set! #*current-locale system-locale) (let ((remember-to-freeze (freeze-in-current-locale #f))) (define (freeze-in-current-locale variable) (set! (frozen-here? #*current-locale variable) #t)) (dolist (variable remember-to-freeze) (freeze-in-current-locale variable))) ;;; eof oaklisp-1.3.3.orig/src/world/op-error.oak0000664000175000000620000000522507725515165017261 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;;; Copyright (C) 1986 Kevin J. Lang and Barak A. Pearlmutter ;;; This entry point strips off the arg field that we don't care about ;;; that the emulator stuck on because funcall is an arged ;;; instruction. (define (no-handler-for-operation n . args) (listify-args failed-funcall . args)) ;;; Leave autoforcing turned off until the facility actually comes up. (define forcible-magic #f) ;;; This function actually does the work. (define (failed-funcall args) (destructure (op . args) args (cond ;; It would be nice if the user level error system could ;; handle this: ((and forcible-magic ;; IS-A? not used because it might force the promise, and ;; then the promse would end up not getting forced. Clear? (subtype? (get-type op) forcible)) (apply (force op) args)) ((not (is-a? op operation)) (signal not-an-operation op args)) ((and (not (null? args)) (is-a? op locatable-operation) (has-method? (get-type (car args)) (locater op))) (when monitor-for-bruce (%write-char #\%)) (contents (apply (locater op) args))) ;; In an ideal world this would be handled at user level: ((and forcible-magic (not (null? args)) ;; IS-A? not used because it might force the promise, and ;; then the promse would end up not getting forced. Clear? (subtype? (get-type (car args)) forcible)) (apply op (force (car args)) (cdr args))) (else (signal operation-not-found op args))))) (set! (nth %arged-tag-trap-table 21) no-handler-for-operation) (set! (nth %arged-tag-trap-table 22) no-handler-for-operation) ;;; This is in direct analogy with the above. (define (no-^super-handler n . args) (listify-args failed-^super . args)) (define (failed-^super args) (destructure (the-type op . args) args (signal ^super-not-found the-type op args))) (set! (nth %arged-tag-trap-table 33) no-^super-handler) (set! (nth %arged-tag-trap-table 34) no-^super-handler) ;;; eof oaklisp-1.3.3.orig/src/world/logops.oak0000664000175000000620000000241107725515165017011 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter (define (xor a b) (if a (not b) b)) (define (and* . args) (cond ((= (rest-length args) 0) t) (else (and*aux . args)))) (define (and*aux arg . args) (cond (arg (if (= (rest-length args) 0) arg (and*aux . args))) (else (consume-args nil . args)))) (define (or* . args) (cond ((= (rest-length args) 0) nil) (else (or*aux . args)))) (define (or*aux arg . args) (cond (arg (consume-args arg . args)) (else (if (= (rest-length args) 0) nil (or*aux . args))))) oaklisp-1.3.3.orig/src/world/patch0symbols.oak0000664000175000000620000000200407725515165020274 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter (iterate go ((curloc %%symloc)(count 0)) (when (< count %%nsyms) (let ((this-one (%crunch (%data curloc) %pointer-tag))) (set! ((%slot 0) this-one) symbol) (go (%increment-locative curloc %%symsize) (+ 1 count))))) ;;; eof oaklisp-1.3.3.orig/src/world/warm.oak0000664000175000000620000000316007725515165016456 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter (define warm-boot-actions '()) (define (warm-boot) (%write-char #\W) (%write-char #\a) (%write-char #\r) (%write-char #\m) (%write-char #\space) (%write-char #\b) (%write-char #\o) (%write-char #\o) (%write-char #\t) (%write-char #\i) (%write-char #\n) (%write-char #\g) (%write-char #\space) (dolist (op warm-boot-actions) (op) (%write-char #\.))) (define (add-warm-boot-action op) (set! warm-boot-actions (append! warm-boot-actions (list op))) op) ;;; Due to load order constraints, some things go here rather than in ;;; the files they are defined in. ;;; from UNDEFINED: (add-warm-boot-action setup-undefined-ivar) ;;; from TAG-TRAP: (add-warm-boot-action setup-tag-traps) ;;; from SUBTYPES: (add-warm-boot-action setup-subtype-table) ;;; from FLUID: (add-warm-boot-action revert-fluid-binding-list) ;;; eof oaklisp-1.3.3.orig/src/world/kernel1-funs.oak0000664000175000000620000000407607725515165020031 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter ;;;;;;;;;;some functions defined here for expediency;;;;;;;;;; (set! subtype? (%allocate operation %simple-operation-length)) (set! %length (%allocate operation %simple-operation-length)) (set! %memq (%allocate operation %simple-operation-length)) (set! %append (%allocate operation %simple-operation-length)) (set! ((%slot 1) subtype?) 0) (set! ((%slot 1) %length) 0) (set! ((%slot 1) %memq) 0) (set! ((%slot 1) %append) 0) ;;; SUBTYPE? code goes here because of some load dependencies. (add-method (subtype? (type type-bp-alist) self potential-super) (not (null? (%assq potential-super type-bp-alist)))) (add-method (%length (object) l) (iterate aux ((l l) (n 0)) (if (null? l) n (aux (cdr l) (+ n 1))))) (add-method (%memq (object) ob l) (cond ((null? l) '()) ((eq? ob (car l)) l) (else (%memq ob (cdr l))))) (add-method (%append (object) a b) (cond ((null? a) b) ((null? b) a) (else (cons (car a) (%append (cdr a) b))))) #| (add-method (subtype? (type supertype-list) self potential-super) (or (eq? self potential-super) (iterate aux ((l supertype-list)) (cond ((null? l) nil) (else (let ((cdrl (cdr l))) (cond ((null? cdrl) (subtype? (car l) potential-super)) ((subtype? (car l) potential-super) t) (else (aux cdrl))))))))) |# oaklisp-1.3.3.orig/src/world/catch.oak0000664000175000000620000000615507725515165016601 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;appropriate types and operations;;;;;;;;; (define-instance escape-object type '(value-stack-offset ;These stack offsets are manipulated context-stack-offset ; only by the micro-engine. saved-wind-count saved-fluid-binding-list) (list object)) (%your-top-wired escape-object) (define-constant %escape-object-length 5) (define throw (add-method ((make operation) (escape-object saved-wind-count saved-fluid-binding-list) tag value) (unwind %windings %wind-count saved-wind-count) ; (set! fluid-binding-list saved-fluid-binding-list) (set-current-fluid-bindings saved-fluid-binding-list) (%throw tag value))) (define-constant %throw (add-method ((make-open-coded-operation '((throw)) 2 1) (escape-object) tag value) (%throw tag value))) ;;; %FILLTAG can never be actually called without losing, only the ;;; open coded version works, so we don't bother with a method for it. (define-constant %filltag (make-open-coded-operation (lambda (ignore) `((filltag ,#*filltag-offset))) ;info from the compiler 1 1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;how catch should be compiled;;;;;;;;;;; (define-syntax (native-catch var . body) `(%catch (let ((,var (%filltag (%allocate escape-object %escape-object-length)))) (set! ((%slot 3) ,var) %wind-count) ; (set! ((%slot 4) ,var) fluid-binding-list) (set! ((%slot 4) ,var) (get-current-fluid-bindings)) ,@body))) (define-syntax (catch v . body) `(native-catch ,v (let ((,v (lambda (val) (throw ,v val)))) ,@body))) ;;; The following method occurs in mac-code. I am showing it here so ;;; that its relationship to the NATIVE-CATCH macro and the %FILLTAG ;;; open coder will be clear. #|| (add-method (gen-code (ast-catch-node expression) self cont) (let ((end-cont (if (eq? cont 'next) (gensym "endcatch") cont))) (let* ((body-code (bind ((#*barrier-node (if (eq? cont 'tail) #*barrier-node (combn-op expression))) ;the LET lambda (#*filltag-offset (1+ (if (eq? cont 'tail) (nguys-to-pop self) 0)))) (gen-code expression 'tail)))) (splice (list (if (eq? end-cont 'tail) '() (list `(push-cxt ,end-cont))) body-code (if (eq? cont 'next) (list end-cont) '())))))) ||# oaklisp-1.3.3.orig/src/world/error3.oak0000664000175000000620000000474207725515165016733 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter ;;; This file contains nice macros and functions for doing typical things ;;; with the error system. ;;; This binds a handler to some class of errors. When such an error ;;; occurs, an appropriate error object is created and the given handler ;;; is then applied to it. Invoke-debugger is a useful handler when ;;; within some other context which is trying to handle a class ;;; of errors that shouldn't be so handled in a limited dynamic context. (define-syntax (bind-error-handler (error-type handler) . body) `(bind ((#*error-handlers (cons (cons ,error-type ,handler) #*error-handlers))) ,@body)) ;;; This construct has a number of different variations, depending on how ;;; much stuff you pass in after the error-type, if any. The simplest form ;;; simply returns #f from the construct if the given type of error occurs. ;;; In more complex forms, if the error occurs the first operation after ;;; the error-type is invoked on the error, and if no error occurs ;;; the other lambda is invoked on the result of the computation. ;;; Syntax: (CATCH-ERRORS (error-type [error-lambda [non-error-lambda]]) ;;; . body) (define-syntax (catch-errors (error-type . more-stuff) . body) (let ((v (genvar))) (destructure** more-stuff (() `(native-catch ,v (bind-error-handler (,error-type (lambda (err) (throw ,v #f))) ,@body))) ((error-lambda) `(native-catch ,v (bind-error-handler (,error-type (lambda (err) (throw ,v (,error-lambda err)))) ,@body))) ((error-lambda noerror-lambda) `(native-catch ,v (,noerror-lambda (bind-error-handler (,error-type (lambda (err) (throw ,v (,error-lambda err)))) ,@body))))))) ;;; eof oaklisp-1.3.3.orig/src/world/cmdline-getopt.oak0000664000175000000620000000342307725515165020425 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1999 Barak A. Pearlmutter. ;;; This can be made more sophisticated later, with command completion etc. ;;; For now is is quite rudimentary. (define (getopt options args) (let aux ((args args)) (if (null? args) '() (cond ((strip-dashes (car args)) => (lambda (a) (cond ((ass equal? a options) => (lambda (o) (let ((n (cadr o)) (f (caddr o))) (let ((stuff (head (cdr args) n))) (catch-errors (general-error (lambda (err) (format standard-error "~&An error occurred while processing switch ~A args ~S~%" a stuff) (report err standard-error) (format standard-error "~%"))) (apply f stuff))) (aux (tail (cdr args) n))))) (else (format standard-error "~&error: unknown switch: ~A" a) (exit 1))))) (else args))))) (define (strip-dashes a) (let ((n (length a))) (and (> n 1) (equal? (nth a 0) #\-) (let ((dashlen (if (equal? (nth a 1) #\-) 2 1))) (and (> n dashlen) (subseq a dashlen (- n dashlen))))))) oaklisp-1.3.3.orig/src/world/reader-macros.oak0000664000175000000620000001275407725515165020245 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C)1986 Kevin J. Lang & Barak A. Pearlmutter ;;; Reader character macros. (define (define-macro-char char func) (set! (nth standard-read-table char) (cons 'terminating-macro func))) (define (define-nonterminating-macro-char char func) (set! (nth standard-read-table char) (cons 'nonterminating-macro func))) ;;; A facility for keeping track of "quotelike" reader macros so the printer ;;; can utilize them. (let ((quotelike-prefixes '())) (define (quotelike-prefix? prefix) (let ((p (assq prefix quotelike-prefixes))) (if p (cdr p) nil))) (define (register-quotelike-prefix char prefix) (let ((p (assq prefix quotelike-prefixes))) (if p (set! (cdr p) char) (set! quotelike-prefixes (cons (cons prefix char) quotelike-prefixes)))))) (define (define-quotelike-macro-char char prefix print-form) (if print-form (register-quotelike-prefix char prefix)) (define-macro-char char (lambda (stream char) (list prefix (read stream))))) ;;; Use the above facilities to define some useful stuff. (define-quotelike-macro-char #\' 'quote #t) (define-quotelike-macro-char #\` 'quasiquote #t) (define-quotelike-macro-char #\ 'fluid #f) ; ascii 22, blob. (define-quotelike-macro-char #\ 'coercer #f) ; ascii 25, rightarrow. ;;; (define (errorful-macro-reader stream char) (warning "a '~A' in an illegal context was ignored.~%" char) the-unread-object) ;;; Let there be readable lists: (define-macro-char #\( (lambda (stream char) (let ((e (read-until #\) #t stream))) e))) (define-macro-char #\) errorful-macro-reader) ;;; Let programs written at Indiana be readable as well: (define-macro-char #\[ (lambda (stream char) (let ((e (read-until #\] #t stream))) e))) (define-macro-char #\] errorful-macro-reader) ;;; "Reserved for the user." (define-macro-char #\{ errorful-macro-reader) (define-macro-char #\} errorful-macro-reader) (define-macro-char #\" (lambda (stream char) (#^string (read-charlist-until stream char)))) (define-macro-char #\| (lambda (stream char) (#^symbol (#^string (read-charlist-until stream char))))) (define-macro-char #\; (lambda (stream char) (iterate aux () (let ((c (read-char stream))) (cond ((or (eq? c the-eof-token) (eq? c #\return) (eq? c #\nl)) the-unread-object) (else (aux))))))) (define-macro-char #\, (lambda (stream char) (let ((n (peek-char stream))) (cond ((eq? n #\@) (read-char stream) (list 'unquote-splicing (read stream))) (else (list 'unquote (read stream))))))) ;;; Read characters up to and including the terminator. #|| ;;; This old code has been replaced by the non-recursive version below ;;; which is more efficient and gives better error messages as well. (define (read-charlist-until stream char) (let ((c (read-char stream))) (cond ((eq? c char) nil) ((eq? c the-eof-token) (error "EOF encountered while reading characters until a ~C." char)) (else (let ((c (if (not (eq? (nth standard-read-table c) 'single-escape)) c (let ((c (read-char stream))) (if (eq? c the-eof-token) (error "EOF encountered after a single escape while reading characters until a ~C." char)) c)))) (cons c (read-charlist-until stream char))))))) ||# (define (read-charlist-until stream char) (iterate aux ((list-top nil)(list-ending nil)) (let ((c (read-char stream))) (cond ((eq? c char) list-top) ((eq? c the-eof-token) (signal eof-reading-chars-until (#^string list-top) char)) (else (let* ((c (if (not (eq? (nth standard-read-table c) 'single-escape)) c (let ((c (read-char stream))) (when (eq? c the-eof-token) (signal eof-after-slash (#^string list-top))) c))) (nl (cons c nil))) (cond ((null? list-top) (aux nl nl)) (else (set! (cdr list-ending) nl) (aux list-top nl))))))))) ;;; This can replace the above if we ever feel like it. Read-charlist-until2 ;;; reads until the passed function is true of the next character read. ;;; Should be benchmarked. #|| (define (read-charlist-until stream char) (read-charlist-until2 stream (lambda (c) (eq? char c)))) ||# (define (read-charlist-until2 stream func) (iterate aux ((list-top nil)(list-ending nil)) (let ((c (read-char stream))) (cond ((func c) list-top) ((eq? c the-eof-token) (signal eof-reading-chars-until (#^string list-top))) (else (let* ((c (if (not (eq? (nth standard-read-table c) 'single-escape)) c (let ((c (read-char stream))) (when (eq? c the-eof-token) (signal eof-after-slash (#^string list-top))) c))) (nl (cons c nil))) (cond ((null? list-top) (aux nl nl)) (else (set! (cdr list-ending) nl) (aux list-top nl))))))))) ;;; eof oaklisp-1.3.3.orig/src/world/print-noise.oak0000664000175000000620000000165707725515165017770 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter (let ((count 0)) (define (print-noise char) (if (= count 0) (%write-char #\nl)) (%write-char char) (set! count (modulo (+ 1 count) 50)))) oaklisp-1.3.3.orig/src/world/obsolese.oak0000664000175000000620000000250307725515165017323 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang and Barak A. Pearlmutter ;;; A macro for declaring an obsolescent synonym for a newly renamed operation. ;;; BUGS: I doubt this works for settable operations. Perhaps this should ;;; operate at the locale level, so it could catch any reference. (define-syntax (define-old-name old new) `(define ,old (let ((already-warned #f)) (lambda ( . args ) (unless already-warned (set! already-warned t) (format standard-error ,(format #f "~~&Warning: ~A is obsolete, use ~A instead.~~%" old new)) (set! ,old ,new)) (,new . args))))) ;;; eof oaklisp-1.3.3.orig/src/world/define.oak0000664000175000000620000000216007725515165016741 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang and Barak A. Pearlmutter ;;; Define define-constant and related forms. (define-syntax (define-constant var . body) `(block0 (define ,var . ,body) (freeze-in-current-locale ',(if (pair? var) (car var) var)))) (define-syntax (define-constant-instance var typ . args) `(block0 (define-instance ,var ,typ . ,args) (freeze-in-current-locale ',var))) ;;; eof oaklisp-1.3.3.orig/src/world/dump-stack.oak0000664000175000000620000000167007725515165017564 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;this function uses a really evil compiler-dependent trick. (define (dump-stack arg . rest) (format #t "~A~%" arg) (set! rest (+ 1 rest)) (dump-stack . rest)) oaklisp-1.3.3.orig/src/world/interpreter.oak0000664000175000000620000002042607725515165020057 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;;; APPLY is a good thing to have in a lisp. #| (labels (((apply0 op arglist . rest) (if (null? arglist) (op . rest) (apply0 op (cdr arglist) (car arglist) . rest))) ((general-apply args) (let ((op (car args)) (args (apply list* (cdr args)))) (apply op args)))) (define (apply op x . args) (cond ((= (rest-length args) 0) (apply0 op (reverse x) . args)) (else (listify-args general-apply op x . args))))) |# (labels (((partially-reverse-4 inlist) (labels (((loop3 old new) (if (null? old) new (loop0 (cdr old) new))) ((loop2 old new) (if (null? old) new (loop3 (cdr old) new))) ((loop1 old new) (if (null? old) new (loop2 (cdr old) new))) ((loop0 old new) (if (null? old) new (loop1 (cdr old) (cons old new))))) (loop0 inlist '()))) ((apply4-aux op rev-chunk-list . rest) (if (null? rev-chunk-list) (op . rest) (let* ((chunk1 (car rev-chunk-list)) (a (car chunk1)) (a-cdr (cdr chunk1)) (b (car a-cdr)) (b-cdr (cdr a-cdr)) (c (car b-cdr)) (c-cdr (cdr b-cdr)) (d (car c-cdr))) (apply4-aux op (cdr rev-chunk-list) a b c d . rest)))) ((general-apply args) (let ((op (car args)) (args (apply list* (cdr args)))) (apply op args)))) (define (apply op inlist . args) (if (> (rest-length args) 0) (listify-args general-apply op inlist . args) (if (null? inlist) (op) (let* ((rev-chunk-list (partially-reverse-4 inlist)) (chunk1 (car rev-chunk-list))) (let ((a (car chunk1)) (a-cdr (cdr chunk1))) (if (null? a-cdr) (apply4-aux op (cdr rev-chunk-list) a) (let ((b (car a-cdr)) (b-cdr (cdr a-cdr))) (if (null? b-cdr) (apply4-aux op (cdr rev-chunk-list) a b) (let ((c (car b-cdr)) (c-cdr (cdr b-cdr))) (if (null? c-cdr) (apply4-aux op (cdr rev-chunk-list) a b c) (let ((d (car c-cdr))) (apply4-aux op (cdr rev-chunk-list) a b c d) ))))))) ))))) (define (interpreter-eval form locale) (i-eval form '() locale)) (define (i-eval expr env locale) (let ((typ (get-type expr))) (cond ((eq? typ symbol) (contents (lookup-var expr env locale #f))) ((eq? typ cons-pair) (i-eval-pair expr env locale)) ((or (eq? typ fixnum) (eq? expr #t) (eq? expr #f)) expr) ((symbol? expr) (contents (lookup-var expr env locale #f))) ((is-a? expr self-evaluatory-mixin) expr) ((pair? expr) (i-eval-pair expr env locale)) (else (cerror "Consider it a constant." "~A found in evaluated position." expr) expr)))) ;;; The primitive special forms: ;;; (%ADD-METHOD (op (typ . ivars) . args) body) ;;; (%CATCH (let (v tag) form)) ;;; (%LABELS clause-list body) ;;; (%MAKE-LOCATIVE sym) ;;; (%BLOCK . forms) ;;; (%IF test a b) ;;; (QUOTE obj) ;;; (REST-LENGTH var) (define (i-eval-pair expr env locale) (let ((op (car expr))) (cond ((eq? op 'quote) (car (cdr expr))) ((eq? op '%make-locative) (lookup-var (cadr expr) env locale #t)) ((eq? op '%if) (i-eval (if (i-eval (car (cdr expr)) env locale) (car (cdr (cdr expr))) (car (cdr (cdr (cdr expr))))) env locale)) ((eq? op '%block) (iterate aux ((l (cdr expr))) (if (null? l) nil (let ((cdrl (cdr l))) (cond ((null? cdrl) (i-eval (car l) env locale)) (else (i-eval (car l) env locale) (aux cdrl))))))) ((eq? op '%labels) (i-eval-labels expr env locale)) ((eq? op '%catch) (i-eval-catch expr env locale)) ((eq? op '%add-method) (i-eval-add-method expr env locale)) ((eq? op 'rest-length) ;; Legality check for symbolhood and length here? (length (i-eval (cadr expr) env locale))) (else (let ((op (i-eval op env locale))) ;; If this evaluated things in the other order, ie. right ;; to left like the compiler, typing (SET! A B) wouldn't ;; install A before the error looking up B. (iterate aux ((l (cdr expr)) (r '())) (cond ((pair? l) (aux (cdr l) (cons (i-eval (car l) env locale) r))) (else (apply op (if (null? l) (reverse r) ;; Rest arguments. (append (reverse r) (i-eval l env locale)))))))))))) ;;; Environments are implemented as opposing ribs of symbols and locatives. (define (lookup-var sym env locale auto-install) (iterate aux ((env env)) (if (not (null? env)) (let ((this-pair (car env))) (iterate aux1 ((vars (car this-pair)) (locs (cdr this-pair))) (cond ((eq? sym vars) ;This clause is for rest args. (let ((x (map contents locs))) (make-locative x))) ((or (null? vars) (symbol? vars)) (aux (cdr env))) ((eq? sym (car vars)) (car locs)) (else (aux1 (cdr vars) (cdr locs)))))) (cond ((variable? locale sym) => identity) (else (if auto-install (warning "Installing ~A in ~A.~%" sym locale) (cerror (format #f "Install ~S in ~S." sym locale) "Variable ~S not found in ~S." sym locale)) (set! (variable-here? locale sym) (%make-cell (make-undefined-variable-value sym)))))))) (define (i-eval-catch expr env locale) (destructure* (#t (('add-method (#t #|makop|# #t #|typ|# thevar) body) #t #|escape|#)) expr (native-catch tag (i-eval body `( ( (,thevar) . (,(make-locative tag)) ) ,@env ) locale)))) (define (i-eval-labels expr env locale) (destructure* (#t clauses body ) expr (let ((vars (map car clauses)) (locs (iterate aux ((l clauses)(r '())) (if (null? l) r (aux (cdr l) (cons (let ((x nil)) (make-locative x)) r)))))) (let ((env (cons (cons vars locs) env))) (iterate aux ((clauses clauses)(locs locs)) (cond ((null? clauses) (i-eval body env locale)) (else (set! (contents (car locs)) (i-eval (car (cdr (car clauses))) env locale)) (aux (cdr clauses) (cdr locs))))))))) ;;; The following two functions really belong somewhere else. (define (proper-list? l) (iterate aux ((l l)) (cond ((null? l) t) ((pair? l) (aux (cdr l))) (else nil)))) (define (proper-length l) (iterate aux ((l l) (n 0)) (cond ((pair? l) (aux (cdr l) (+ n 1))) (else n)))) (define (i-eval-add-method expr env locale) (destructure* (#t ( op ( typ . ivars ) . args ) body ) expr (let ((op (i-eval op env locale)) (typ (i-eval typ env locale))) (let ((rest-args-okay? (not (proper-list? args))) (desired-args (proper-length args)) (f (lambda (rest-arglist) (let ((arg-locs (mapcdr (locater car) rest-arglist)) (ivar-locs (and rest-arglist ivars (%locate-ivars typ (car rest-arglist) ivars)))) (i-eval body `((,ivars . ,ivar-locs) (,args . ,arg-locs) ,@env) locale))))) (add-method (op (typ) . rest-args) (if (or (< (rest-length rest-args) desired-args) (and (not rest-args-okay?) (not (= (rest-length rest-args) desired-args)))) ((if rest-args-okay? incorrect-nargs-gte incorrect-nargs) desired-args . rest-args) (listify-args f . rest-args))))))) (define-instance %locate-ivars operation) (add-method (%locate-ivars (type ivar-list) self obj var-list) (let ((frame-loc (%increment-locative (%set-tag obj %locative-tag) (cdr (%assq self ((%slot 6) (get-type obj))))))) (iterate aux ((l var-list)(locs '())) (cond ((null? l) (reverse locs)) (else (aux (cdr l) (cons (%increment-locative frame-loc (position-in-list (car l) ivar-list)) locs))))))) ;;; eof oaklisp-1.3.3.orig/src/world/predicates.oak0000664000175000000620000000404707725515165017640 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter ;;; The following can fail for things that don't inherit from OBJECT, ;;; or that do it in the wrong order. These anomalous conditions should ;;; probably be detected at type creation time, and cause the type to be ;;; uninstantiable. (define (type-pred typ) (let ((op (make operation))) ;; Force delays and check 'em again. (add-method (op (forcible) self) (op (force self))) ;; Yes for instances of TYP. (add-method (op (typ) self) #t) ;; No is the default. (add-method (op (object) self) #f) op)) (define (inverse-type-pred typ) (let ((op (make operation))) ;; Force delays and check 'em again. (add-method (op (forcible) self) (op (force self))) ;; No for instances of TYP. (add-method (op (typ) self) #f) ;; Yes is the default. (add-method (op (object) self) #t) op)) (define number? (type-pred number)) (define integer? (type-pred integer)) (define fixnum? (type-pred fixnum)) (define symbol? (type-pred symbol)) (define string? (type-pred string)) (define char? (type-pred character)) (define pair? (type-pred pair)) (define list? (type-pred list-type)) (define atom? (inverse-type-pred pair)) (define procedure? (type-pred operation)) (define vector? (type-pred simple-vector)) ;null? is defined in subprimitive.oak. oaklisp-1.3.3.orig/src/world/mac-compiler1.oak0000664000175000000620000001744607725515165020155 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang and Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; build the AST ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;This looks at a piece of code and determines its type. (define-instance node-type-to-build operation) ;;; Bound to #t while parsing the user code. (set! #*worry-about-constants #f) (add-method (node-type-to-build (object) form) (if #*worry-about-constants (cerror "Consider it a constant." "~A found in evaluated position." form)) ast-constant-node) (add-method (node-type-to-build (self-evaluatory-mixin) form) ast-constant-node) (add-method (node-type-to-build (symbol) form) ast-variable-node) (add-method (node-type-to-build (pair) form) (let ((kar (car form))) (cond ((eq? kar 'quote) ast-constant-node) ((eq? kar '%if) ast-if-node) ((eq? kar '%set) ast-set-node) ((eq? kar '%catch) ast-catch-node) ((eq? kar 'rest-length) ast-variable-node) ((eq? kar '%add-method) ast-method-node) ((eq? kar '_%add-method) ast-method-node) ((eq? kar '%make-locative) ast-make-locative-node) ((eq? kar '%block) ast-block-node) ((eq? kar '%labels) ast-labels-node) (else ast-combination-node)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;This returns the parse tree for a piece of code. (define (code->ast form) (if (is-a? form ast-node) form (make (node-type-to-build form) form))) ;this handy variant fills in the enclosing-contour slots ;of code to be inserted in the tree. (define (addedcode->ast form model-node) (let ((new-ast (code->ast form))) (stash-enclosing-contour new-ast (node-enclosing-contour model-node)) new-ast)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;The following initialize methods do the work of walking the code ;and building the AST. (add-method (initialize (ast-node enclosing-contour stack-map) self) (set! enclosing-contour nil) (set! stack-map nil) self) (add-method (initialize (ast-if-node predicate consequent alternate) self form) (cond ((and (eq? (car form) '%if) (= (length form) 4)) (set! predicate (code->ast (second form))) (set! consequent (code->ast (third form))) (set! alternate (code->ast (fourth form)))) (else (error "Error parsing ~S as a %IF." form))) (^super ast-node initialize self)) (add-method (initialize (ast-constant-node value name origin) self form) (set! name nil) (set! origin nichevo) (cond ((or (is-a? form self-evaluatory-mixin) (atom? form)) (set! value form)) ((and (eq? (car form) 'quote) (pair? (cdr form))) (set! value (cadr form))) (else (error "Error parsing ~S as a constant." form))) (^super ast-node initialize self)) (add-method (initialize (ast-set-node variable expression) self form) (cond ((and (eq? (car form) '%set) (= (length form) 3) (symbol? (second form))) (set! variable (code->ast (second form))) (set! expression (code->ast (third form)))) (else (error "Error parsing ~S as a %SET." form))) (^super ast-node initialize self)) (add-method (initialize (ast-variable-node name var-type source-contour car-pos?) self form) (cond ((symbol? form) (set! var-type '()) (set! source-contour '()) (set! car-pos? '()) (set! name form)) ((eq? (first form) 'rest-length) (set! var-type '()) (set! source-contour '()) (set! car-pos? '()) (set! name (second form))) (else (error "Error parsing ~S as a variable." form))) (^super ast-node initialize self)) (add-method (initialize (ast-contour-node localvars nojumplist closedlist environment envlist) self locals form) (set! #*contour-nodes? #t) (set! localvars locals) (set! nojumplist nil) (set! closedlist nil) (set! environment nil) (set! envlist nil) (if (not (every? symbol? localvars)) (error "Variables names must be symbols in ~S." form)) (^super ast-node initialize self)) (define (genlabel/1 x) (gensym "LABEL")) (add-method (initialize (ast-labels-node labellist gensymlist lambdalist body) self form) (set! #*labels-count (1+ #*labels-count)) (cond ((and (eq? (car form) '%labels) (= (length form) 3) (list? (second form))) (set! labellist (map first (second form))) (set! gensymlist (map genlabel/1 labellist)) (set! lambdalist (map (lambda (x) (let ((the-code (code->ast (second x)))) (if (is-a? the-code ast-method-node) the-code (error "~S is not a lambda" (second x))))) (second form))) (set! body (code->ast (third form)))) (else (error "Error parsing ~S as a %LABELS." form))) (^super ast-contour-node initialize self labellist form)) (add-method (initialize (ast-method-node method-type status op primitivep inlabels? ivarlist ivarmap arglist heaplist rest-name body) self form) (destructure* (kind-o-method (inop (typ . ivars) . args) bod) form (unless (or (eq? kind-o-method '%add-method) (eq? kind-o-method '_%add-method)) (error "Error parsing ~S as a %METHOD." form)) (set! status 'method) (set! inlabels? nil) (set! ivarlist ivars) (set! ivarmap nil) (set! heaplist nil) (set! primitivep (eq? kind-o-method '_%add-method)) (set! rest-name (improper-list? args)) ;; rest-name goes on front of arglist: (set! arglist (if rest-name (cons rest-name (make-proper args)) args)) (set! op (code->ast inop)) ;see below (set! method-type (code->ast typ)) (set! body (code->ast bod)) (^super ast-contour-node initialize self (union ivarlist arglist) form))) (add-method (initialize (ast-make-locative-node variable) self form) (cond ((and (eq? (car form) '%make-locative) (= (length form) 2) (symbol? (second form))) (set! variable (code->ast (second form)))) (else (error "Error parsing ~S as a %MAKE-LOCATIVE." form))) (^super ast-node initialize self)) (add-method (initialize (ast-block-node body) self form) (if (not (eq? (car form) '%block)) (error "Error parsing ~S as a BLOCK." form)) (cond ((> (length form) 1) (set! body (map code->ast (cdr form)))) ((= (length form) 1) (set! body (list (code->ast '()))))) (^super ast-node initialize self)) (add-method (initialize (ast-combination-node op args tail-pos? rest-name) self form) (set! tail-pos? nil) (set! rest-name (improper-list? form)) (let ((proper-form (if rest-name (make-proper form) form))) (cond ((> (length proper-form) 0) (set! op (code->ast (car proper-form))) (set! args (map code->ast (cdr proper-form)))) (else (error "Error parsing ~S as a combination." form)))) (if rest-name (set! rest-name (code->ast rest-name)) (set! rest-name nichevo)) (^super ast-node initialize self)) (add-method (initialize (ast-catch-node expression) self form) (cond ((and (eq? (car form) '%catch) (= (length form) 2)) (set! expression (code->ast (second form)))) (else (error "Error parsing ~S as a %CATCH." form))) (^super ast-node initialize self)) ;;; eof oaklisp-1.3.3.orig/src/world/fluid.oak0000664000175000000620000000567107725515165016624 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter ;;; This file contains code that implements fluid variables. (define top-level-fluid-binding-list (list (cons nil nil))) (define get-current-fluid-bindings (add-method ((make operation)) (let ((z (or %no-threading (%load-process)))) (if (eq? z 0) fluid-binding-list (fluid-bindings z))))) (define set-current-fluid-bindings (add-method ((make operation) new-binding-list) (let ((z (or %no-threading (%load-process)))) (if (eq? z 0) (set! fluid-binding-list new-binding-list) (set! (fluid-bindings z) new-binding-list))))) (define add-to-current-fluid-bindings (add-method ((make operation) c-cell) (let ((z (or %no-threading (%load-process)))) (if (eq? z 0) (set! (cdr top-level-fluid-binding-list) (cons c-cell (cdr top-level-fluid-binding-list))) (append! (fluid-bindings z) (cons c-cell nil)))))) ;;; This is to be called at warm boot time: (define (revert-fluid-binding-list) (set! fluid-binding-list top-level-fluid-binding-list)) ;(define (revert-fluid-binding-list) ; (set-current-fluid-bindings top-level-fluid-binding-list)) ;(define (revert-fluid-binding-list) ; (set-current-fluid-bindings (cons (cons nil nil) nil))) ;;; And at cold boot time too, I suppose: (revert-fluid-binding-list) #| ;;; This must be delayed until later in the world building process. (define-syntax (fluid x) `(%fluid ',x)) |# (define-constant-instance %fluid locatable-operation) (add-method (%fluid (symbol) sym) (iterate aux () (let ((x (%assq sym (get-current-fluid-bindings)))) (cond (x => cdr) (else (cerror (format #f "Try looking up (FLUID ~S) again." sym) "(FLUID ~S) not found." sym) (aux)))))) (add-method ((setter %fluid) (symbol) sym val) (let ((x (%assq sym (get-current-fluid-bindings)))) (cond (x (set! (cdr x) val)) (else (add-to-current-fluid-bindings (cons sym val)) val)))) (add-method ((locater %fluid) (symbol) sym) (iterate aux () (let ((x (%assq sym (get-current-fluid-bindings)))) (cond (x (make-locative (cdr x))) (else (cerror (format #f "Try looking up (FLUID ~S) again." sym) "Locative to (FLUID ~S) not found." sym) (aux)))))) ;;; eof oaklisp-1.3.3.orig/src/world/pl.oak0000664000175000000620000000134707725515165016130 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA (%write-char #\+) oaklisp-1.3.3.orig/src/world/rational.oak0000664000175000000620000001516407725515165017330 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986,7,8 Kevin J. Lang & Barak A. Pearlmutter. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Define the FRACTION type, which consists of those rationals that ;;; are not integers. (define-instance fraction type '(the-numerator the-denominator) (list rational object)) (add-method (initialize (fraction the-numerator the-denominator) self top bot) (set! the-numerator top) (set! the-denominator bot) self) ;;; This controls whether fractions are printed 7/3, 21/3, or 2.333333. ;;; ;;; Possible values: NORMAL, FANCY, and FLOAT for regular (potentially ;;; improper) fractions, proper ones, and decimal series. (set! #*fraction-display-style 'normal) ;;; This controls how many digits past the decimal point are printed in ;;; FLOAT mode. (set! #*float-digits 10) (add-method (print (fraction the-numerator the-denominator) self stream) (case #*fraction-display-style ((normal) (format stream "~A/~A" the-numerator the-denominator)) ((fancy) (let ((num (cond ((negative? the-numerator) (format stream "-") (- the-numerator)) (else the-numerator)))) (cond ((< num the-denominator) (format stream "~A/~A" num the-denominator)) (else (let* ((y (quotient num the-denominator)) (z (- num (* y the-denominator)))) (format stream "~A~A/~A" y z the-denominator)))))) ((float) (labels (((pos x) (let* ((y (truncate x)) (radix #*print-radix)) (format stream "~D." y) (iterate aux ((x (- x y)) (digits #*float-digits)) (cond ((or (zero? x) (zero? digits)) #f) (else (let* ((x (* x radix)) (y (truncate x))) (format stream "~D" y) (aux (- x y) (- digits 1))))))))) (cond ((negative? the-numerator) (format stream "-") (pos (- self))) (else (pos self))))) (else (error "Unknown fraction printing style ~S." #*fraction-display-style)))) (add-method (plus/2 (fraction the-numerator the-denominator) x y) (fselect-type y ((rational) (let ((numy (numerator y)) (deny (denominator y))) (fx/ (+ (* the-numerator deny) (* numy the-denominator)) (* the-denominator deny)))) ((complex) (plus/2 y x)) (otherwise (error "Illegal second arg: (%PLUS ~A ~A)~%" x y)))) (add-method (times/2 (fraction the-numerator the-denominator) x y) (fselect-type y ((rational) (fx/ (* the-numerator (numerator y)) (* the-denominator (denominator y)))) ((complex) (times/2 y x)) (otherwise (error "Illegal second arg: (%TIMES ~A ~A)" x y)))) (add-method (/ (rational) x y) (fselect-type y ((rational) (fx/ (* (numerator x) (denominator y)) (* (denominator x) (numerator y)))) ((complex) (/r y x)) (otherwise (error "Illegal second arg: (/ ~A ~A)" x y)))) (add-method (/r (rational) x y) (fselect-type y ((integer) (fx/ (* (denominator x) y) (numerator x))) ((rational) (fx/ (* (denominator x) (numerator y)) (* (numerator x) (denominator y)))) (otherwise (error "Illegal second arg: (/ ~A ~A)" x y)))) (add-method (minus (fraction the-numerator the-denominator) self) ;; Make the fraction directly, since no normalization will be needed. (make fraction (- the-numerator) the-denominator)) (add-method (subtract/2 (fraction the-numerator the-denominator) x y) (fselect-type y ((rational) (let ((numy (numerator y)) (deny (denominator y))) (fx/ (- (* the-numerator deny) (* numy the-denominator)) (* the-denominator deny)))) (otherwise (^super number subtract/2 x y)))) ;;;;;;;;;;;;;;;;;;;;; ;;; Comparison ;;;;;;;;;;;;;;;;;;;;; (add-method (= (fraction the-numerator the-denominator) x y) (fselect-type y ((fraction) (and (= the-numerator (numerator y)) (= the-denominator (denominator y)))) ((number) #f) (otherwise (error "Illegal second arg (= ~D ~D)." x y)))) (add-method (< (fraction the-numerator the-denominator) x y) (fselect-type y ((rational) (< (* the-numerator (denominator y)) (* (numerator y) the-denominator))) (otherwise (error "Illegal second arg (< ~D ~D)." x y)))) ;;; For speed: (add-method (negative? (fraction the-numerator) x) (negative? the-numerator)) (add-method (positive? (fraction the-numerator) x) (positive? the-numerator)) ;;;;;;;;;;;;;;;;;;;;;; (add-method (abs (fraction the-numerator the-denominator) self) (if (negative? the-numerator) ;; Sure to be no normalization, so make the fraction directly. (make fraction (- the-numerator) the-denominator) self)) #|| (add-method (sqrt (fraction the-numerator the-denominator) self) (/ (sqrt the-numerator) (sqrt the-denominator))) ||# (define-instance numerator operation) (define-instance denominator operation) (add-method (numerator (fraction the-numerator) self) the-numerator) (add-method (denominator (fraction the-denominator) self) the-denominator) (add-method (numerator (integer) self) self) (add-method (denominator (integer) self) 1) ;;;;;;;;;;;; (define (fx/ top bot) (labels (((aux top bot neg?) (if (= bot 1) (if neg? (- top) top) (let ((d (gcd top bot))) (if (= d bot) (quotient (if neg? (- top) top) bot) (make fraction (quotient (if neg? (- top) top) d) (quotient bot d))))))) (cond ((zero? bot) (error "Division by zero: (FX/ ~D ~D)." top bot)) ((zero? top) 0) ((negative? top) (if (negative? bot) (aux (- top) (- bot) #f) (aux (- top) bot #t))) (else (if (negative? bot) (aux top (- bot) #t) (aux top bot #f)))))) (define (gcd a b) (iterate gcd ((a a)(b b)) (cond ((< a b) (let ((p (* a (quotient b a)))) (if (= p b) a (gcd (- b p) a)))) ((> a b) (let ((p (* b (quotient a b)))) (if (= p a) b (gcd (- a p) b)))) (else a)))) (define (lcm a b) (cond ((or (= a 0) (= b 0)) 0) (else (/ (* a b) (gcd a b))))) ;;; eof oaklisp-1.3.3.orig/src/world/truth.oak0000664000175000000620000000214407725515165016657 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter ;;; Define the canonical truth value, that has a print syntax #T. The ;;; world builder has it made already, so we patch the reference. (define-instance truths type '() (list self-evaluatory-mixin object)) (set! ((%slot 0) t) truths) (define-constant else t) (add-method (print (truths) self stream) (format stream "#T")) ;;; eof oaklisp-1.3.3.orig/src/world/hash-table.oak0000664000175000000620000001662307725515165017530 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;;; The access interface is PRESENT?, same as for SAT-TREEs. Returns ;;; a PAIR whose CAR is the key and whose CDR is the associated value. ;;; A different interface to hash tables is provided by the T-style ;;; TABLE-ENTRY operation which returns the associated value or #f if ;;; the key isn't in the table. ;;; The setter of either operation can be used to add, modify, and ;;; remove associations. ;;; Set PRESENT? to a new value, not a (key . val) pair. ;(define-instance present? settable-operation) ;(define-instance table-entry settable-operation) (define-instance hash-table type '() '()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; generic hash tables (define-instance generic-hash-table type '(table count size key-op =?) (list hash-table object)) (add-method (initialize (generic-hash-table key-op =? table count size) self the-key-op the-=?) (set! key-op the-key-op) (set! =? the-=?) (set! count 0) (set! size 17) (set! table (make simple-vector size)) (dotimes (i size) (set! (nth table i) '())) self) (add-method (present? (generic-hash-table key-op =? table count size) self x) (ass =? x (nth table (modulo (key-op x) size)))) (add-method ((setter present?) (generic-hash-table key-op =? table count size) self x v) (let* ((key (key-op x)) (index (modulo key size)) (lslot (make-locative (nth table index))) (slot (contents lslot)) (entry (ass =? x slot))) (if v (if entry (set! (cdr entry) v) ;modify (block ;insert (set! (contents lslot) (cons (cons x v) slot)) (set! count (+ count 1)) (when (> (+ count count) size) (resize self (+ 1 (+ size size)))))) (when entry ;remove (set! (contents lslot) (del (lambda (k p) (=? k (car p))) x slot)) (set! count (- count 1))))) v) (define-instance resize operation) (add-method (resize (generic-hash-table key-op table count size) self new-size) (let ((old-table table) (old-size size)) (set! table (make simple-vector new-size)) (set! size new-size) (dotimes (i new-size) (set! (nth table i) '())) (dotimes (i old-size) (dolist (entry (nth old-table i)) (let* ((key (key-op (car entry))) (j (modulo key size)) (jloc (make-locative (nth table j)))) (set! (contents jloc) (cons entry (contents jloc)))))) self)) ;;; String hash tables: (define-instance string-hash-key operation) #|| (add-method (string-hash-key (string char-count) s) (iterate aux ((i 0) (k 0)) (if (= i char-count) k (aux (+ i 1) (bit-xor (rot-left k 7) (%character->fixnum (nth s i))))))) ||# ;;; Maybe the following will speed up reading: (add-method (string-hash-key (string char-count) s) (if (eq? char-count 0) 0 (let ((n (quotient (+ char-count (- %chars-per-word 1)) %chars-per-word)) (p0 (make-locative (%vref s 0)))) (iterate aux ((i 0) (k 0)) (if (= i n) k (aux (+ i 1) (bit-xor (rot-left k (- (* 8 %chars-per-word) 1)) (contents (%increment-locative p0 i))))))))) (define (make-string-hash-table) (make generic-hash-table string-hash-key equal?)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; EQ? hash tables (define-instance eq-hash-table type '(table count size) (list hash-table object)) (add-method (initialize (eq-hash-table table count size) self) (set! count 0) (set! size 17) (set! table (make simple-vector size)) (dotimes (i size) (set! (nth table i) '())) self) (add-method (present? (eq-hash-table table count size) self x) (%assq x (%vref-nocheck table (modulo (object-hash x) size)))) (add-method ((setter present?) (eq-hash-table table count size) self x v) (let* ((lslot (make-locative (nth table (modulo (object-hash x) size)))) (slot (contents lslot)) (entry (%assq x slot))) (if v (if entry (set! (cdr entry) v) ;modify (block ;insert (set! (contents lslot) (cons (cons x v) slot)) (set! count (+ count 1)) (when (> (+ count count) size) (resize self (+ 1 (+ size size)))))) (if entry (block ;remove (set! (contents lslot) (del (lambda (k p) (eq? k (car p))) x slot)) (set! count (- count 1))) #f))) ;noop v) (add-method (resize (eq-hash-table table count size) self new-size) (let ((old-table table) (old-size size)) (set! table (make simple-vector new-size)) (set! size new-size) (dotimes (i new-size) (set! (nth table i) '())) (dotimes (i old-size) (dolist (entry (nth old-table i)) (push (nth table (modulo (object-hash (car entry)) size)) entry))) self)) (define (make-eq-hash-table) (make eq-hash-table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; EQUAL-HASH-TABLE (define (tree-hash x) (tree-hash-aux x 0)) (define (tree-hash-aux x d) (cond ((= d 4) #x162534) ((pair? x) (bit-xor (tree-hash-aux (car x) (+ d 1)) (rot-left (tree-hash-aux (cdr x) (+ d 1)) 17))) ((string? x) (string-hash-key x)) ((vector? x) (vector-hash-key-aux x d)) (else (object-hash x)))) (define (vector-hash-key-aux x d) (let ((l (length x))) ;; First clause is not portable--relies on uniqueness of the empty vector. (cond ((zero? l) (object-hash x)) (else (bit-xor (bit-xor (rot-left l 23) (rot-left (tree-hash-aux (nth x 0) (+ d 1)) 17)) (bit-xor (rot-left (tree-hash-aux (nth x (modulo 7 l)) (+ d 1)) 11) (tree-hash-aux (nth x (modulo 39 l)) (+ d 1)))))))) (define-instance equal-hash-table type '() (list generic-hash-table)) (add-method (initialize (equal-hash-table) self) (^super generic-hash-table initialize self tree-hash equal?)) (define (make-equal-hash-table) (make equal-hash-table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; shared methods (add-method (print (hash-table) self stream) (format stream "#" (length self) self)) (dolist (typ (list generic-hash-table eq-hash-table)) (add-method (length (typ count) self) count) (add-method (#^list-type (typ table size) self) (iterate aux ((i 0)(l '())) (if (= i size) l (aux (+ i 1) (append (nth table i) l))))) (add-method ((setter length) (typ table count size) self new-length) (when (!= new-length 0) (error "Attempt to set hash table ~S to non-zero length." self)) (set! count 0) (dotimes (i size) (set! (nth table i) '()))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; table-entry interface, like in T (define-instance table-entry settable-operation) (set! (setter table-entry) (setter present?)) (add-method (table-entry (hash-table) tab key) (cond ((present? tab key) => cdr) (else #f))) ;;; eof oaklisp-1.3.3.orig/src/world/icky-macros.oak0000664000175000000620000000214207725515165017730 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Barak A. Pearlmutter and Kevin J. Lang ;;; The following two things are a hack, but they should speed up string ;;; access by a lot, and this optimization is anything but premature. (define-syntax (%fixnum->character x) `(%crunch (ash-left ,x 6) 1)) (define-syntax (%character->fixnum x) `(ash-left (%data ,x) -6)) ;;; End of icky macros that compile to tense code. oaklisp-1.3.3.orig/src/world/bp-alist.oak0000664000175000000620000000160307725515165017223 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter. (define-instance get-bp-alist operation) (add-method (get-bp-alist (type type-bp-alist) self) type-bp-alist) oaklisp-1.3.3.orig/src/world/super.oak0000664000175000000620000000223007725515165016643 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter ;;; Define the ^super operation, which is basically written in ;;; microcode. One day ^super should be open coded everywhere. (define (^super the-type the-op self . args) ;; Hack NARGS and tail off to the ^SUPER opcode. ;; This leaves an unnecessary (RETURN) in the object file. (set! ((%register 'nargs)) (- ((%register 'nargs)) 2)) (%^super-tail the-type the-op self)) ;;; eof oaklisp-1.3.3.orig/src/world/bignum2.oak0000664000175000000620000000404307725515165017054 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter. (define (bignum-speed-test) (set frog1 (apply * (subseq prime-list 0 60))) (set frog2 (apply * (subseq prime-list 60 45))) (set frog3 (* frog1 frog2)) (set frog4 (make bignum 1 (reverse (bignum-digits frog3)))) (%gc) (set junk (quotient frog1 123456)) (map quotient (list (time (10) (+ frog3 frog4)) (time (10) (- frog3 frog4)) (time (5) (* frog1 frog2)) (time (1) (quotient frog4 frog2))) '(1000 1000 1000 1000))) ; (), 1, (1 . 2), ((2 . 3) . 1), ((1 . 4) . (2 . 3)) (define-instance insert-balanced-tree operation) (add-method (insert-balanced-tree (null-type) self new) new) (add-method (insert-balanced-tree (object) self new) (cons self new)) (add-method (insert-balanced-tree (cons-pair the-car the-cdr) self new) (let ((old-car the-car)) (set! the-car (insert-balanced-tree the-cdr new)) (set! the-cdr old-car)) self) (define-instance multiply-tree operation) (add-method (multiply-tree (null-type) self) 1) (add-method (multiply-tree (object) self) self) (add-method (multiply-tree (cons-pair the-car the-cdr) self) (* (multiply-tree the-car) (multiply-tree the-cdr))) (define (fact n) (iterate next ((n n)(tree '())) (if (zero? n) (multiply-tree tree) (next (- n 1)(insert-balanced-tree tree n))))) ;;; eof oaklisp-1.3.3.orig/src/world/numbers.oak0000664000175000000620000004476307725515165017201 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter ;;; This contains definitions for all the numeric stuff. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The numeric type heirarchy is as follows. Entries with *s are ;;; instantiable. ;;; ;;; number ;;; / \ ;;; real complex* ;;; / \ ;;; rational float* ;;; / \ ;;; integer fraction* ;;; / \ ;;; fixnum* bignum* (define-constant-instance number coercable-type '() (list self-evaluatory-mixin)) (set! #^number (make (mix-types oc-mixer (list foldable-mixin operation)))) (add-method (#^number (number) x) x) (define-constant-instance real type '() (list number)) (define-constant-instance rational type '() (list real)) (define-constant-instance integer type '() (list rational)) ;;; This gets redone when float.oak is loaded: (define-instance float type '() (list real)) (define-constant fixnum (the-runtime fixnum)) (initialize fixnum '() (list integer object)) ;;; Tell the bytecode emulator about this: ;(set! ((%register 'fixnum-type)) (the-runtime fixnum)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-instance / operation) (define-instance /r operation) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; These are the operations that get trapped to when the corresponding ;;; instruction fails. That is the only time they should ever be called. ;;; They should never be called directly by user code, or system code ;;; either for that matter. (define-instance plus/2 operation) (define-instance times/2 operation) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (labels ((+/2 (lambda (x y) (+ x y))) (+/3 (lambda (x y z) (+ x y z))) (+/4 (lambda (x y z p) (+ x y z p))) (+/5 (lambda (x y z p d) (+ x y z p d))) (+/>5 (lambda (x y z p d q . args) (let ((z (+ x y z p d q))) (cond ((= 0 (rest-length args)) z) ((= 1 (rest-length args)) (+/2 z . args)) ((= 2 (rest-length args)) (+/3 z . args)) ((= 3 (rest-length args)) (+/4 z . args)) ((= 4 (rest-length args)) (+/5 z . args)) (else (+/>5 z . args))))))) (define-constant + (add-method ((make-fancy-open-coded-operation (list foldable-mixin) (lambda (n) (make list-type (- n 1) '(plus))) nil 1) (object) . args) (cond ((= 0 (rest-length args)) 0) ((= 1 (rest-length args)) (%return)) ((= 2 (rest-length args)) (+/2 . args)) ((= 3 (rest-length args)) (+/3 . args)) ((= 4 (rest-length args)) (+/4 . args)) ((= 5 (rest-length args)) (+/5 . args)) (else (+/>5 . args)))))) (add-method (plus/2 (fixnum) x y) (cond ((eq? (get-type y) fixnum) (plus/2 (#^bignum x) y)) (else (plus/2 y x)))) (add-method (times/2 (fixnum) x y) (cond ((eq? (get-type y) fixnum) (times/2 (#^bignum x) y)) (else (times/2 y x)))) (define-constant 1+ (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((load-imm 1)(plus)) 1 1) (number) x) (+ 1 x))) (define-constant minus (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((negate)) 1 1) (fixnum) x) (if (most-negative-fixnum? x) least-positive-bignum (- x)))) (define-instance subtract/2 operation) (add-method (subtract/2 (number) x y) (+ x (- y))) (labels ((-aux (lambda (x y . args) (if (zero? (rest-length args)) (- x y) (-aux (- x y) . args))))) (define-constant - (add-method ((make-fancy-open-coded-operation (list foldable-mixin) (lambda (n) (cond ((zero? n) (error "The - operation requires at least one argument.")) ((= n 1) '((negate))) (else (make list-type (- n 1) '(subtract))))) nil 1) (number) x . args) (if (zero? (rest-length args)) (- x) (-aux x . args))))) (labels ((*/2 (lambda (x y) (* x y))) (*/3 (lambda (x y z) (* x y z))) (*/4 (lambda (x y z p) (* x y z p))) (*/5 (lambda (x y z p d) (* x y z p d))) (*/>5 (lambda (x y z p d q . args) (let ((z (* x y z p d q))) (cond ((= 0 (rest-length args)) z) ((= 1 (rest-length args)) (*/2 z . args)) ((= 2 (rest-length args)) (*/3 z . args)) ((= 3 (rest-length args)) (*/4 z . args)) ((= 4 (rest-length args)) (*/5 z . args)) (else (*/>5 z . args))))))) (define-constant * (add-method ((make-fancy-open-coded-operation (list foldable-mixin) (lambda (n) (make list-type (- n 1) '(times))) nil 1) (object) . args) (cond ((= 0 (rest-length args)) 1) ((= 1 (rest-length args)) (%return)) ((= 2 (rest-length args)) (*/2 . args)) ((= 3 (rest-length args)) (*/3 . args)) ((= 4 (rest-length args)) (*/4 . args)) ((= 5 (rest-length args)) (*/5 . args)) (else (*/>5 . args)))))) (define-constant remainder (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((remainder)) 2 1) (fixnum) x y) (cond ((zero? y) (error "Illegal second arg: (REMAINDER ~D ~D).~%" x y)) ((eq? (get-type y) fixnum) (remainder x y)) ((eq? (get-type y) bignum) (remainder (#^bignum x) y)) (else ;;(error "Illegal second arg: (REMAINDER ~D ~D).~%" x y) (^super integer remainder x y) )))) (define-constant modulo (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((modulo)) 2 1) (fixnum) x y) (cond ((zero? y) (error "Illegal second arg: (MODULO ~D ~D).~%" x y)) ((eq? (get-type y) fixnum) (modulo x y)) ((eq? (get-type y) bignum) (modulo (#^bignum x) y)) (else (^super integer modulo x y))))) (add-method (modulo (real) x y) (- x (* y (floor (/ x y))))) (add-method (remainder (real) x y) (- x (* y (truncate (/ x y))))) (define-old-name mod modulo) (define-constant quotient (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((div)) 2 1) (fixnum) x y) (cond ((zero? y) (error "Illegal second arg: (QUOTIENT ~D ~D).~%" x y)) ((eq? (get-type y) bignum) 0) ((eq? (get-type y) fixnum) ;; Watch it, this can cause an infinite loop. ;(warning "Call to (QUOTIENT ~D ~D).~%" x y) (quotient x y)) (else (error "Illegal second arg: (QUOTIENT ~D ~D).~%" x y))))) (define-old-name div quotient) (define-constant quotientm (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((quotientm)) 2 1) (fixnum) x y) (cond ((zero? y) (error "Illegal second arg: (QUOTIENTM ~D ~D).~%" x y)) ((eq? (get-type y) fixnum) ;; Watch it, this can cause an infinite loop. ;(warning "Call to (QUOTIENTM ~D ~D).~%" x y) (quotientm x y)) (else (error "Illegal second arg: (QUOTIENTM ~D ~D).~%" x y))))) (define-constant zero? (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((=0?)) 1 1) (fixnum) x) (zero? x))) (add-method (zero? (number) x) nil) (define-constant negative? (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((<0?)) 1 1) (fixnum) x) (negative? x))) (add-method (negative? (real) x) (< x 0)) (define-constant positive? (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((LOAD-IMM 0) (<)) 1 1) (fixnum) x) (positive? x))) (add-method (positive? (real) x) (< 0 x)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Comparison operators ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; NOTE: < and = must be defined for all subtypes of real; the other ;;; comparison operators are defined in terms of these. (define-constant = (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((=)) 2 1) (fixnum) x y) (fselect-type y ((fixnum) (= x y)) ((number) #f) (otherwise (error "Illegal second arg (= ~D ~D).~%" x y))))) (define-constant < (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((<)) 2 1) (fixnum) x y) (fselect-type y ((fixnum) (< x y)) ((bignum) (not (negative? y))) ((rational) (< (* x (denominator y)) (numerator y))) ((float) (if (zero? x) (< x (float-sign y)) (< (#^float x) y))) (otherwise (error "Illegal second arg (< ~D ~D).~%" x y))))) ;;; (define-constant > (make-fancy-open-coded-operation (list foldable-mixin backwards-args-mixin) '((<)) 2 1)) (define-constant >= (make-fancy-open-coded-operation (list foldable-mixin) '((<) (not)) 2 1)) (define-constant != (make-fancy-open-coded-operation (list foldable-mixin) '((=) (not)) 2 1)) (define-constant <= (make-fancy-open-coded-operation (list foldable-mixin backwards-args-mixin) '((<) (not)) 2 1)) (add-method (> (object) x y) (> x y)) (add-method (>= (object) x y) (>= x y)) (add-method (!= (object) x y) (!= x y)) (add-method (<= (object) x y) (<= x y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Rotations and shifts (define-constant rot-left (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((rot)) 2 1) (fixnum) x y) (fselect-type y ((fixnum) (rot-left x y)) (otherwise (error "Illegal second arg (ROT-LEFT ~D ~D).~%" x y))))) (define-constant rot-right (add-method ((make-fancy-open-coded-operation (list foldable-mixin backwards-args-mixin) '((negate)(swap 1)(rot)) 2 1) (fixnum) x y) (rot-left x (- y)))) (define-constant ash-left (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((ash)) 2 1) (fixnum) x y) (fselect-type y ((fixnum) (ash-left x y)) (otherwise (error "Illegal second arg (ASH-LEFT ~D ~D).~%" x y))))) (define-constant ash-right (add-method ((make-fancy-open-coded-operation (list foldable-mixin backwards-args-mixin) '((negate)(swap 1)(ash)) 2 1) (fixnum) x y) (ash-left x (- y)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Bitwise operations (define-constant bit-not (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((bit-not)) 1 1) (fixnum) x) (bit-not x))) (define-constant bit-and (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((bit-and)) 2 1) (fixnum) x y) (fselect-type y ((fixnum) (bit-and y x)) (otherwise (error "Bad second arg (BIT-AND ~D ~D)." x y))))) (define-constant bit-or (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((bit-or)) 2 1) (fixnum) x y) (fselect-type y ((fixnum) (bit-or y x)) (otherwise (error "Bad second arg (BIT-OR ~D ~D)." x y))))) (define-constant bit-xor (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((bit-xor)) 2 1) (fixnum) x y) (fselect-type y ((fixnum) (bit-xor y x)) (otherwise (error "Bad second arg (BIT-XOR ~D ~D)." x y))))) (define-constant bit-nand (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((bit-nand)) 2 1) (fixnum) x y) (fselect-type y ((fixnum) (bit-nand y x)) (otherwise (error "Bad second arg (BIT-NAND ~D ~D)." x y))))) (define-constant bit-andca (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((bit-andca)) 2 1) (integer) x y) (bit-and x (bit-not y)))) (define-constant bit-nor (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((bit-nor)) 2 1) (fixnum) x y) (fselect-type y ((fixnum) (bit-nor y x)) (otherwise (error "Bad second arg (BIT-NOR ~D ~D)." x y))))) (define-constant bit-equiv (add-method ((make-fancy-open-coded-operation (list foldable-mixin) '((bit-equiv)) 2 1) (fixnum) x y) (fselect-type y ((fixnum) (bit-equiv y x)) (otherwise (error "Bad second arg (BIT-EQUIV ~D ~D)." x y))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-constant-instance abs (mix-types oc-mixer (list foldable-mixin operation))) (define-constant-instance expt (mix-types oc-mixer (list foldable-mixin operation))) (define-constant-instance expt/r (mix-types oc-mixer (list foldable-mixin operation))) (add-method (abs (real) x) (if (negative? x) (- x) x)) (add-method (expt (number) x y) (expt/r y x)) (add-method (expt/r (integer) n a) (cond ((negative? n) (/ 1 (expt/r (- n) a))) ((zero? n) 1) (else (let* ((rec (expt/r (quotient n 2) a)) (srec (* rec rec))) (if (even? n) srec (* a srec)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; recoded below to allow multiple arguments ; ; (define-constant-instance max ; (mix-types oc-mixer (list foldable-mixin operation))) ; (define-constant-instance min ; (mix-types oc-mixer (list foldable-mixin operation))) ; ; (add-method (max (object) x y) ; (if (> x y) x y)) ; (add-method (min (object) x y) ; (if (> x y) y x)) ; These macros should be flushed when it becomes convenient. ; The open coded function is faster. (local-syntax (max-macro2 clause1 clause2) (let ((var1 (genvar)) (var2 (genvar))) `(let* ((,var2 ,clause2) (,var1 ,clause1)) (if (> ,var2 ,var1) ,var2 ,var1)))) (local-syntax (max-macro . clauses) (let ((n-clauses (length clauses))) (cond ((zero? n-clauses) (error "max requires at least one argument")) ((= 1 n-clauses) (car clauses)) (else `(max-macro2 ,(car clauses) (max-macro ,@(cdr clauses))))))) (local-syntax (min-macro2 clause1 clause2) (let ((var1 (genvar)) (var2 (genvar))) `(let* ((,var2 ,clause2) (,var1 ,clause1)) (if (< ,var2 ,var1) ,var2 ,var1)))) (local-syntax (min-macro . clauses) (let ((n-clauses (length clauses))) (cond ((zero? n-clauses) (error "min requires at least one argument")) ((= 1 n-clauses) (car clauses)) (else `(min-macro2 ,(car clauses) (min-macro ,@(cdr clauses))))))) (let* ((generate-bytecodes-for-max2 (lambda () (let ((noswap (generate-symbol 'noswap))) (copy `((load-stk 1) (load-stk 1) (<) (branch-nil ,noswap) (swap 1) (label ,noswap) (blast 1) ))))) (generate-bytecodes-for-max (lambda (n) (cond ((zero? n) (error "max requires at least one argument")) ((= 1 n) '()) (else (splice (map (lambda (ignore) (generate-bytecodes-for-max2)) (iota (- n 1))))))))) (define-constant max (make-fancy-open-coded-operation (list foldable-mixin) generate-bytecodes-for-max nil 1))) (let* ((generate-bytecodes-for-min2 (lambda () (let ((noswap (generate-symbol 'noswap))) (copy `((load-stk 1) (load-stk 1) (<) (branch-nil ,noswap) (swap 1) (label ,noswap) (blast 1) ))))) (generate-bytecodes-for-min (lambda (n) (cond ((zero? n) (error "min requires at least one argument")) ((= 1 n) '()) (else (splice (map (lambda (ignore) (generate-bytecodes-for-min2)) (iota (- n 1))))))))) (define-constant min (make-fancy-open-coded-operation (list foldable-mixin) generate-bytecodes-for-min nil 1))) (labels (((max-helper-1 a) a) ((max-helper-2 a b) (max-macro a b)) ((max-helper-3 a b c) (max-macro a b c)) ((max-helper-4 a b c d) (max-macro a b c d)) ((max-helper-5+ a b c d e . rest) (let ((max-so-far (max-macro a b c d e))) (cond ((> (rest-length rest) 3) (max-helper-5+ max-so-far . rest)) ((= (rest-length rest) 3) (max-helper-4 max-so-far . rest)) ((= (rest-length rest) 2) (max-helper-3 max-so-far . rest)) ((= (rest-length rest) 1) (max-helper-2 max-so-far . rest)) (else max-so-far))))) (add-method (max (object) . rest) (cond ((> (rest-length rest) 4) (max-helper-5+ . rest)) ((= (rest-length rest) 4) (max-helper-4 . rest)) ((= (rest-length rest) 3) (max-helper-3 . rest)) ((= (rest-length rest) 2) (max-helper-2 . rest)) ((= (rest-length rest) 1) (max-helper-1 . rest)) (else (error "MAX requires at least one argument"))))) (labels (((min-helper-1 a) a) ((min-helper-2 a b) (min-macro a b)) ((min-helper-3 a b c) (min-macro a b c)) ((min-helper-4 a b c d) (min-macro a b c d)) ((min-helper-5+ a b c d e . rest) (let ((min-so-far (min-macro a b c d e))) (cond ((> (rest-length rest) 3) (min-helper-5+ min-so-far . rest)) ((= (rest-length rest) 3) (min-helper-4 min-so-far . rest)) ((= (rest-length rest) 2) (min-helper-3 min-so-far . rest)) ((= (rest-length rest) 1) (min-helper-2 min-so-far . rest)) (else min-so-far))))) (add-method (min (object) . rest) (cond ((> (rest-length rest) 4) (min-helper-5+ . rest)) ((= (rest-length rest) 4) (min-helper-4 . rest)) ((= (rest-length rest) 3) (min-helper-3 . rest)) ((= (rest-length rest) 2) (min-helper-2 . rest)) ((= (rest-length rest) 1) (min-helper-1 . rest)) (else (error "MIN requires at least one argument"))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;(define-instance exp operation) ;;; Make the usual equality tests work on numbers. (dolist (op (list eqv? equal?)) (add-method (op (number) x y) (and (eq? (get-type x) (get-type y)) (= x y))) (add-method (op (fixnum) x y) (eq? x y))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Open code EVEN? and ODD? sometime in the future. (define-constant even? (add-method ((make (mix-types oc-mixer (list foldable-mixin operation))) (integer) x) (zero? (remainder x 2)))) (define-constant odd? (add-method ((make (mix-types oc-mixer (list foldable-mixin operation))) (integer) x) (not (zero? (remainder x 2))))) (define-instance exact? operation) (define-instance inexact? operation) (add-method (exact? (number) x) #f) (add-method (exact? (rational) x) #t) (add-method (inexact? (number) x) (not (exact? x))) ;;; eof oaklisp-1.3.3.orig/src/world/kernel1-freeze.oak0000664000175000000620000000235407725515165020333 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Barak A. Pearlmutter & Kevin J. Lang (let ((remember-to-freeze '())) (define (freeze-in-current-locale variable) (if variable (push remember-to-freeze variable) remember-to-freeze))) ;; Now freeze everything that should have been frozen in the files preceding ;; this that couldn't be because this stuff wasn't defined yet: (dolist (v '(operation object make type %varlen-make initialize nil t %method fixnum cons-pair locative %closed-environment)) (freeze-in-current-locale v)) ;;; eof oaklisp-1.3.3.orig/src/world/kernel1-make.oak0000664000175000000620000000363507725515165017773 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;;; Copyright (C) 1987 Kevin J. Lang and Barak A. Pearlmutter ;;; how to make things ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Make MAKE (set! make (%allocate operation %simple-operation-length)) (set! %varlen-make (%allocate operation %simple-operation-length)) (set! ((%slot 1) make) 0) (set! ((%slot 1) %varlen-make) 0) (set! variable-length-mixin 'not-really-varlen-mixin) (add-method (make (type instance-length) self . args) (if (subtype? self variable-length-mixin) (%varlen-make self . args) (let ((new-guy (%allocate self instance-length))) (initialize new-guy . args)))) ;;; This %varlen-allocate instruction exists to close a tiny GC ;;; window. (add-method (%varlen-make (type instance-length) self ncells . args) (let* ((guylen (+ instance-length ncells)) (new-guy (%varlen-allocate self guylen))) (initialize new-guy ncells . args))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Make INITIALIZE (set! initialize (%allocate operation %simple-operation-length)) (set! ((%slot 1) initialize) 0) ;;; This took (self . more) and check if more was empty; no more. (add-method (initialize (object) self) self) ;;; eof oaklisp-1.3.3.orig/src/world/st.oak0000664000175000000620000000134707725515165016143 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA (%write-char #\*) oaklisp-1.3.3.orig/src/world/del.oak0000664000175000000620000000324707725515165016262 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;;; Copyright (C) 1989 Barak A. Pearlmutter & Kevin J. Lang ;;; When a unix level DEL signal comes in, this is what gets signaled. (define-instance user-interrupt type '() (list proceedable-condition object)) (add-method (report (user-interrupt) self stream) (format stream "User interrupt.~%")) (add-method (initialize (user-interrupt) self) (^super proceedable-condition initialize self "Resume the interrupted computation.")) ;;; This handles the emulator's interface to a user interrupt, which ;;; consists of pretending that a NOOP instruction failed and passing the ;;; old value of NARGS to be restored before returning. (define (usr-intr n) (signal user-interrupt) (set! ((%register 'nargs)) n) (%return)) (set! (nth %argless-tag-trap-table 0) usr-intr) ;;; Make this condition land us in the debugger instead of being ignored: (set! #*error-handlers (append! #*error-handlers (list (cons user-interrupt invoke-debugger)))) ;;; eof oaklisp-1.3.3.orig/src/world/bignum.oak0000664000175000000620000005531307725515165017000 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter. ;;;;;;;;;;;;;;;;;;;;;; create the type ;;;;;;;;;;;;;;;;;; (define-instance bignum coercable-type '(sign digits) (list integer object)) (create-accessors bignum bignum- sign digits) (add-method (bignum-sign (fixnum) x) (if (negative? x) -1 1)) (add-method (bignum-digits (fixnum) x) (normalize-digitlist (cond ((negative? x) (list (- x))) ((zero? x) '()) (else (list x))) 0)) (define (bignum-digit-count x) (length (bignum-digits x))) (add-method (initialize (bignum sign digits) self sgn digs) (set! sign sgn) (set! digits digs) self) (add-method (#^bignum (fixnum) x) (make bignum (bignum-sign x) (bignum-digits x))) ;;; Make a bignum unless the thing will fit in a fixnum. (define (maybe-make-bignum sign digits) (if (or (and (= sign 1) (digitlist-< digits (bignum-digits least-positive-bignum))) (and (= sign -1) (digitlist-< digits (bignum-digits least-negative-bignum)))) (if (null? digits) 0 (iterate aux ((l digits) (place sign) (total 0)) (let ((total (fx-plus total (fx-times (car l) place))) (cdrl (cdr l))) (if (null? cdrl) total (aux cdrl (fx-times place bignum-base) total))))) (make bignum sign digits))) ;;; Base 10,000, little endian, signed magnitude. ;;; If you change this you have to change PRINT-4-BIGNUM-DECIMAL-DIGITS (define decimal-digits-per-bignum-chunk 4) (define-constant bignum-base (expt 10 decimal-digits-per-bignum-chunk)) (set! #*bignum-debug #f) (add-method (print (bignum sign digits) self stream) (cond (#*bignum-debug (format stream "#" sign digits) self) ;; Special case base 10: ((= 10 #*print-radix) (when (= sign -1) (write-char stream #\-)) (let ((rdigs (reverse digits))) (print (car rdigs) stream) (dolist (d (cdr rdigs) self) (print-4-bignum-decimal-digits d stream)))) (else (^super integer print self stream)))) (define (print-4-bignum-decimal-digits q stream) (let* ((q (print-place q 1000 stream)) (q (print-place q 100 stream)) (q (print-place q 10 stream))) (write-char stream (digit->char q)))) ;;;;;;;;;;;;;;;; interface functions ;;;;;;;;;;;;;;;; (add-method (minus (bignum sign digits) x) (maybe-make-bignum (- sign) digits)) (add-method (= (bignum sign digits) x y) (fselect-type y ((bignum) (and (= sign (bignum-sign y)) (equal? digits (bignum-digits y)))) ((number) #f) (otherwise (error "Domain error in second arg (= ~D ~D)." x y)))) (add-method (negative? (bignum sign) x) (= sign -1)) (add-method (< (bignum sign digits) x y) (let ((ytype (get-type y)) (xneg (= sign -1))) (if (eq? ytype fixnum) xneg (let ((yneg (negative? y))) (cond ((and xneg (not yneg)) #t) ((and (not xneg) yneg) #f) ((eq? ytype bignum) (xor xneg (let ((ydigits (bignum-digits y))) (iterate aux ((xd digits) (yd ydigits)) (cond ((null? xd) (if (null? yd) (samelen-digitlist-< digits ydigits) #t)) ((null? yd) #f) (else (aux (cdr xd) (cdr yd)))))))) ((subtype? ytype rational) (< (* x (denominator y)) (numerator y))) (else (error "Domain error in second argument (< ~S ~S)." x y))))))) (add-method (plus/2 (bignum sign digits) x y) (fselect-type y ((integer) (let ((ydigits (bignum-digits y)) (ysign (bignum-sign y))) (cond ((= sign ysign) (maybe-make-bignum sign (sum-digitlists digits ydigits))) ((digitlist-< ydigits digits) (maybe-make-bignum sign (diff-digitlists digits ydigits))) (else (maybe-make-bignum ysign (diff-digitlists ydigits digits)))))) ((number) (plus/2 y x)) (otherwise (error "Nonnumeric addition (plus/2 ~S ~S)" x y)))) (add-method (times/2 (bignum sign digits) x y) (if (zero? y) 0 (fselect-type y ((fixnum) (let ((ydigits (bignum-digits y)) (ysign (bignum-sign y))) (maybe-make-bignum (fx-times sign ysign) (if (< (if (negative? y) (- y) y) bignum-base) (simple-multiply-step (car ydigits) digits) (multiply-digitlists digits ydigits) )))) ((integer) (let ((ydigits (bignum-digits y)) (ysign (bignum-sign y))) (maybe-make-bignum (fx-times sign ysign) ;;(mult-digitlists digits ydigits) (multiply-digitlists digits ydigits) ))) ((number) (times/2 y x)) (otherwise (error "Nonnumeric argument (TIMES/2 ~S ~S)" x y))))) (add-method (quotient (bignum sign digits) x y) (fselect-type y ((integer) (let ((ydigits (bignum-digits y)) (ysign (bignum-sign y))) (maybe-make-bignum (fx-times sign ysign) (first (quorem-digitlists digits ydigits)) ))) (otherwise (error "bad second argument (QUOTIENT ~S ~S)" x y)))) (add-method (remainder (bignum sign digits) x y) (fselect-type y ((integer) (let ((ydigits (bignum-digits y)) (ysign (bignum-sign y))) (maybe-make-bignum sign (second (quorem-digitlists digits ydigits)) ))) (otherwise ;;(error "bad second argument (REMAINDER ~S ~S)" x y) (^super integer remainder x y) ))) ;;; For quotientm and modulo we copy the code from the emulator. (add-method (quotientm (bignum) x y) (let ((a (quotient x y))) (if (or (and (negative? x) (not (negative? y)) (> (* a y) x)) (and (negative? y) (not (negative? x)) (< (* a y) x))) (- a 1) a))) (add-method (modulo (bignum) x y) (let ((a (remainder x y))) (if (or (and (negative? a) (not (negative? y))) (and (negative? y) (not (negative? x)) (not (negative? a)))) (+ a y) a))) ;;;;;;;;;;;;;;;; addition ;;;;;;;;;;;;;;;; ;bignum-speed-test time: 22 msec (define (sum-digitlists l1 l2) (let ((root (cons 'root '()))) (labels (((step-both in1 in2 carry prevpair) (if (null? in1) (if (null? in2) (block ;both empty (when (not (= 0 carry)) (set (cdr prevpair) (list carry))) (cdr root)) ;in1 empty (let ((x (fx-plus carry (car in2)))) (step-one (cdr in2) (quotient x bignum-base) (set! (cdr prevpair) (cons (remainder x bignum-base) '()))))) (if (null? in2) ;in2 empty (let ((x (fx-plus carry (car in1)))) (step-one (cdr in1) (quotient x bignum-base) (set! (cdr prevpair) (cons (remainder x bignum-base) '())))) ;neither empty (let ((x (fx-plus (fx-plus carry (car in1))(car in2)))) (step-both (cdr in1) (cdr in2) (quotient x bignum-base) (set! (cdr prevpair) (cons (remainder x bignum-base) '()))))))) ((step-one in1 carry prevpair) (cond ((null? in1) ;done (when (not (= 0 carry)) (set (cdr prevpair) (list carry))) (cdr root)) ((zero? carry) ;done (set! (cdr prevpair) in1) (cdr root)) (else ;iterate (let ((x (fx-plus carry (car in1)))) (step-one (cdr in1) (quotient x bignum-base) (set! (cdr prevpair) (cons (remainder x bignum-base) '())))))))) (step-both l1 l2 0 root)))) ;;;;;;;;;;;;;;;;;;;;; subtraction ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;bignum-speed-test time: 64 msec (define (diff-digitlists l1 l2) (let ((root (cons 'root '()))) (labels (((step-both in1 in2 carry prevpair last-nonzero-pair) (if (null? in2) (if (null? in1) ;both empty (if (not (= 0 carry)) (error "negative result in diff-digitlist") (block (set (cdr last-nonzero-pair) '()) (cdr root))) ;in2 empty (let* ((x (fx-plus carry (car in1))) (xmb (modulo x bignum-base)) (newpair (cons xmb '()))) (step-one (cdr in1) (quotientm x bignum-base) (set! (cdr prevpair) newpair) (if (not (= 0 xmb)) newpair last-nonzero-pair)))) ;neither empty (let* ((x (fx-plus carry (- (car in1)(car in2)))) (xmb (modulo x bignum-base)) (newpair (cons xmb '()))) (step-both (cdr in1) (cdr in2) (quotientm x bignum-base) (set! (cdr prevpair) newpair) (if (not (= 0 xmb)) newpair last-nonzero-pair))))) ((step-one in1 carry prevpair last-nonzero-pair) (cond ((null? in1) ;done (when (not (zero? carry)) (error "negative result in diff-digitlist")) (set (cdr last-nonzero-pair) '()) (cdr root)) ((zero? carry) ;done (set! (cdr prevpair) in1) (cdr root)) (else ;iterate (let* ((x (fx-plus carry (car in1))) (xmb (modulo x bignum-base)) (newpair (cons xmb '()))) (step-one (cdr in1) (quotientm x bignum-base) (set! (cdr prevpair) newpair) (if (not (= 0 xmb)) newpair last-nonzero-pair))))))) (step-both l1 l2 0 root root)))) ;;;;;;;;;;;;;;;multiplication;;;;;;;;;;;;;;;;;;;; ; This uses the Strassen divide and conquer algorithm for long lists, ; and the regular n-squared algorithm for short lists. (define multiplication-tradeoff-point 16) ; Seems like a decent value, but not proven optimal. ; The value must be at least 2 to terminate recursion. ;bignum-speed-test time: 392 msec (define (multiply-digitlists x y) (if (or (null? x)(null? y)) '() (let* ((lenx (length x)) (leny (length y))) (labels (((guts x y lenx leny) ;enforce lenx >= leny (cond ((< leny multiplication-tradeoff-point);; N^2 algorithm (let ((accumulator (make list-type (- (+ lenx leny) 1) 0))) (iterate next2 ((digs y)(acc accumulator)) (when digs (let ((dig (car digs))) (when (not (zero? dig)) (iterate next1 ((accleft acc)(listleft x)(carry 0)(i lenx)) (if (= 1 i) (let* ((d (fx-plus (fx-plus carry (car accleft)) (fx-times (car listleft) dig))) (d/b (quotient d bignum-base)) (dmb (remainder d bignum-base))) (set (car accleft) dmb) (when (not (= 0 d/b)) (set (cadr (block (when (null? (cdr accleft)) (set (cdr accleft) (cons '() '()))) accleft)) d/b)) acc) (let ((d (fx-plus (fx-plus carry (car accleft)) (fx-times (car listleft) dig)))) (set! (car accleft) (remainder d bignum-base)) (next1 (cdr accleft) (cdr listleft) (quotient d bignum-base) (- i 1))))) )) (next2 (cdr digs) (cdr acc)))) accumulator) ) (else;; N^1.59 algorithm (let* ((lenx/2 (quotient lenx 2)) (ab (extract-subdigitlists x lenx lenx/2)) (a (cdr ab)) (b (car ab)) (cd (extract-subdigitlists y leny lenx/2)) (c (cdr cd)) (d (car cd)) (w (multiply-digitlists b d))) (if (not (null? c)) ;;regular case (let* ((u (multiply-digitlists (sum-digitlists a b) (sum-digitlists c d))) (v (multiply-digitlists a c))) (shift-sum-digitlists (shift-sum-digitlists v (diff-digitlists u (sum-digitlists v w)) lenx/2) w lenx/2)) ;;simplified case where c=0. (shift-sum-digitlists (diff-digitlists (multiply-digitlists (sum-digitlists a b) d) w) w lenx/2))))))) (if (> leny lenx) (guts y x leny lenx) (guts x y lenx leny)))))) ;(ex-sdl '(0 1 2 3 4 5) 6 2) -> '((0 1) . (2 3 4 5)) ;(ex-sdl '(1 0 0 3 4 5) 6 3) -> '((1) . (3 4 5)) ;(ex-sdl '(0 1 2 3 4 5) 6 7) -> '((0 1 2 3 4 5) . '()) (define (extract-subdigitlists l len part1-len) (if (> len part1-len) (let ((root (cons 'root '()))) (iterate next ((left l)(i part1-len)(prevpair root)(last-nonzero-pair root)) (if (= 0 i) (block (set (cdr last-nonzero-pair) '()) (cons (cdr root) left)) (let* ((carleft (car left)) (newpair (cons carleft '()))) (next (cdr left) (- i 1) (set (cdr prevpair) newpair) (if (= 0 carleft) last-nonzero-pair newpair)))))) (cons l '()))) (define (shift-sum-digitlists x y d) ;shifts x by d before summing (let ((root (cons 'root '()))) (iterate next ((y y)(d d)(prev-pair root)) (cond ((= 0 d) (set (cdr prev-pair) (sum-digitlists x y)) (cdr root)) ((null? y) (next y (- d 1) (set (cdr prev-pair) (cons 0 '())))) (else (next (cdr y) (- d 1) (set (cdr prev-pair) (cons (car y) '())))))))) ; this is used by times/2 and quorem-digitlists-to-get-digit. (define (simple-multiply-step dig l) (if (= 0 dig) '() (let ((root (cons 'root '()))) (labels (((step-one in1 carry prevpair) (cond ((null? in1) ;done (when (not (= 0 carry)) (set (cdr prevpair) (list carry))) (cdr root)) (else ;iterate (let ((x (fx-plus carry (fx-times dig (car in1))))) (step-one (cdr in1) (quotient x bignum-base) (set! (cdr prevpair) (cons (remainder x bignum-base) '())))))))) (step-one l 0 root))))) ;;;;;;;;;;;;;;;division;;;;;;;;;;;;;;;;;;;; ; Warning; this code assumes that two ; bignum digits fit into a fixnum. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;bignum-speed-test time: 2680 msec ; Diglist and divisor are digit-lists. ; Returns (list quotient remainder) (let ((last-inlist #t) (last-divisor #t) (last-quorem #t)) ;cache for last values computed (define (quorem-digitlists inlist divisor) (if (and (eq? inlist last-inlist) (eq? divisor last-divisor)) last-quorem (let ((lenin (length inlist)) (lendiv (length divisor))) (if (if (= lenin lendiv) ;this expression is (digitlist-< inlist divisor) (samelen-digitlist-< inlist divisor) (< lenin lendiv)) (list (list 0) inlist) ;quotient is 0 (iterate next ((todo (reverse (subseq inlist 0 (- lenin lendiv)))) (quotient-remainder (accumulating-quorem-digitlists-to-get-digit '() (subseq inlist (- lenin lendiv) lendiv) divisor))) (if (not (null? todo)) (next (cdr todo) (accumulating-quorem-digitlists-to-get-digit (first quotient-remainder) (let ((newdividend (cons (car todo) (second quotient-remainder)))) (if (equal? newdividend '(0)) '() newdividend)) divisor)) (block (set last-inlist inlist) (set last-divisor divisor) (set last-quorem quotient-remainder))))))))) ;; ;Returns (list (digit . old-digs) remainder) (define (accumulating-quorem-digitlists-to-get-digit old-digs inlist divisor) (let* ((quorem (quorem-digitlists-to-get-digit inlist divisor)) (quo (car quorem)) (rem (cdr quorem))) (list (if (and (= 0 quo)(null? old-digs)) '() (cons quo old-digs)) rem))) ; Call the following helper function only when you are sure ; that the quotient can be expressed by a single digit. ; all arguments are digit lists ;returns (digit . remainder) (let ((last-short-divisor #t) ;cache some internal info (fix-divisor #t) (last-long-divisor #t) (rev-divisor #t)) (define (quorem-digitlists-to-get-digit inlist divisor) ;; (when #*bignum-debug (%write-char #\|)) (let ((lenin (length inlist)) (lendiv (length divisor))) (cond ((if (= lenin lendiv) ; special case when answer is 0 (samelen-digitlist-< inlist divisor) (< lenin lendiv)) (cons 0 inlist)) ((< (+ lenin lendiv) 5) ; special cases for short digitlists (when (not (eq? last-short-divisor divisor)) (set! last-short-divisor divisor) (set! fix-divisor (if (= lendiv 2) (fx-plus (fx-times bignum-base (cadr divisor)) (car divisor)) (car divisor)))) (cond ((= lendiv 2) (let ((fix-dividend (fx-plus (fx-times bignum-base (cadr inlist)) (car inlist)))) (cons (quotient fix-dividend fix-divisor) (bignum-digits (remainder fix-dividend fix-divisor))))) ((= lenin 2) (let ((fix-dividend (fx-plus (fx-times bignum-base (cadr inlist)) (car inlist)))) (cons (quotient fix-dividend fix-divisor) (bignum-digits (remainder fix-dividend fix-divisor))))) (else (let ((fix-dividend (car inlist))) (cons (quotient fix-dividend fix-divisor) (bignum-digits (remainder fix-dividend fix-divisor))))))) (else ;; general case: 3+ digits in inlist, and 2+ or 3+ digits in divisor (when (not (eq? last-long-divisor divisor)) (set! last-long-divisor divisor) (set! rev-divisor (reverse divisor))) (let* ((rev-inlist (reverse inlist)) (inlist-hi (car rev-inlist)) (divisor-hi (car rev-divisor)) (guessdig (cond ((> inlist-hi 999) (quotient (fx-plus (fx-times 10000 inlist-hi) (cadr rev-inlist)) (if (= lenin lendiv) (fx-plus (fx-times 10000 divisor-hi) (cadr rev-divisor)) divisor-hi))) ((> inlist-hi 99) (quotient (fx-plus (fx-times 100000 inlist-hi) (fx-plus (fx-times 10 (cadr rev-inlist)) (quotient (caddr rev-inlist) 1000))) (if (= lenin lendiv) (fx-plus (fx-times 100000 divisor-hi) (fx-plus (fx-times 10 (cadr rev-divisor)) (quotient (caddr rev-divisor) 1000))) (fx-plus (fx-times 10 divisor-hi) (quotient (cadr rev-divisor) 1000))))) ((> inlist-hi 9) (quotient (fx-plus (fx-times 1000000 inlist-hi) (fx-plus (fx-times 100 (cadr rev-inlist)) (quotient (caddr rev-inlist) 100))) (if (= lenin lendiv) (fx-plus (fx-times 1000000 divisor-hi) (fx-plus (fx-times 100 (cadr rev-divisor)) (quotient (caddr rev-divisor) 100))) (fx-plus (fx-times 100 divisor-hi) (quotient (cadr rev-divisor) 100))))) (else (quotient (fx-plus (fx-times 10000000 inlist-hi) (fx-plus (fx-times 1000 (cadr rev-inlist)) (quotient (caddr rev-inlist) 10))) (if (= lenin lendiv) (fx-plus (fx-times 10000000 divisor-hi) (fx-plus (fx-times 1000 (cadr rev-divisor)) (quotient (caddr rev-divisor) 10))) (fx-plus (fx-times 1000 divisor-hi) (quotient (cadr rev-divisor) 10))))))) (guessdig ; adjust in case rounding threw us out of bounds (cond ((< guessdig 1) 1) ((>= guessdig bignum-base) (- bignum-base 1)) (else guessdig))) (guessprod (simple-multiply-step guessdig divisor)) (lowbound (diff-digitlists inlist divisor))) (iterate next ((dig guessdig)(prod guessprod)(first-try #t)) ;iterate to fix guess (cond ((digitlist-< inlist prod) ;; (when #*bignum-debug (%write-char #\-)) (if first-try (next (- dig 1) (diff-digitlists prod divisor) #f) (let* ((distance (diff-digitlists prod inlist)) ;recurse (quorem (quorem-digitlists-to-get-digit distance divisor))) (if (null? (cdr quorem)) (cons (- dig (car quorem)) '()) (cons (- dig (car quorem) 1) (diff-digitlists divisor (cdr quorem))))))) ((digitlist-< lowbound prod) (cons dig (diff-digitlists inlist prod))) (else ;; this case never happens (%write-char #\+) (next (1+ dig) (sum-digitlists prod divisor) #f)))) )))))) ;;;;;;;;;;;; assorted stuff ;;;;;;;;;;;;;;;;;; (define (normalize-digitlist l carry) (if (null? l) (if (= carry 0) '() (normalize-digitlist (list carry) 0)) (let* ((x (+ carry (car l))) (x/b (quotientm x bignum-base)) (xmb (modulo x bignum-base))) (cons xmb (normalize-digitlist (cdr l) x/b))))) (define (digitlist-< l1 l2) (let ((len1 (length l1)) (len2 (length l2))) (if (= len1 len2) (samelen-digitlist-< l1 l2) (< len1 len2)))) (define (samelen-digitlist-< l1 l2) (iterate next ((l1 (reverse l1))(l2 (reverse l2))) (cond ((null? l1) #f) ((= (car l1)(car l2)) (next (cdr l1)(cdr l2))) (else (< (car l1)(car l2)))))) ;;; NOTE: bignum-speed-test, balanced tree fact, etc. moved to bignum2.oak. ;;; Convoluted code defeats constant folding. No big numbers in bignum.oa! (define most-negative-fixnum (ash-left (let ((x 1)) x) 29)) (define most-positive-fixnum (- (+ most-negative-fixnum 1))) (let* ((l0 (list most-positive-fixnum)) (l1 (normalize-digitlist l0 0)) (l2 (normalize-digitlist l1 1)) (l3 (normalize-digitlist l2 1))) (define least-positive-bignum (make bignum 1 l2)) (define least-negative-bignum (make bignum -1 l3))) #| ; The following version of sum-digitlists might be useful ; on a machine that lacks integer division instructions. (define-syntax (iterative-positive-quorem (number divisor quotient-name remainder-name) . body) (let ((labsym (genvar))) `(iterate ,labsym ((,quotient-name 0) (,remainder-name ,number)) (cond ((< ,remainder-name ,divisor) ,@body) (else (,labsym (1+ ,quotient-name)(- ,remainder-name ,divisor))))))) (define (sum-digitlists l1 l2) (let ((root (cons 'root '()))) (labels (((step-both in1 in2 carry prevpair) (if (null? in1) (if (null? in2) (block ;both empty (when (not (= 0 carry)) (set (cdr prevpair) (list carry))) (cdr root)) ;in1 empty (iterative-positive-quorem ((+ carry (car in2)) bignum-base quo rem) (step-one (cdr in2) quo (set! (cdr prevpair) (cons rem '()))))) (if (null? in2) ;in2 empty (iterative-positive-quorem ((+ carry (car in1)) bignum-base quo rem) (step-one (cdr in1) quo (set! (cdr prevpair) (cons rem '())))) ;neither empty (iterative-positive-quorem ((+ carry (car in1)(car in2)) bignum-base quo rem) (step-both (cdr in1) (cdr in2) quo (set! (cdr prevpair) (cons rem '()))))))) ((step-one in1 carry prevpair) (cond ((null? in1) ;done (when (not (= 0 carry)) (set (cdr prevpair) (list carry))) (cdr root)) ((zero? carry) ;done (set! (cdr prevpair) in1) (cdr root)) (else ;iterate (iterative-positive-quorem ((+ carry (car in1)) bignum-base quo rem) (step-one (cdr in1) quo (set! (cdr prevpair) (cons rem '())))))))) (step-both l1 l2 0 root)))) |# (add-method (bit-not (bignum) x) (- (+ 1 x))) ;;; eof oaklisp-1.3.3.orig/src/world/multi-em.oak0000664000175000000620000000456507725515165017253 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;; ;; The functions in this souce file assist in the creation and management ;; of heavyweight threads. ;; ;; ;; Creates a new heavyweight thread ;; This method takes one argument, the function to be run in the ;; virtual machine running on the new heavyweight thread. ;; The given function should loop forever. If it returns, a seg-fault ;; will occur (it's not a bug, it's a feature). ;; This function returns t if the thread is created, nil if it could ;; not be created. ;; (define-constant %make-heavyweight-thread (add-method ((make-open-coded-operation '((make-heavyweight-thread)) 1 1) (object) target) (%make-heavyweight-thread target))) ;; ;; Returns the variable stored in the "process" register. Each virtual ;; machine has its own process register. It is used with the process ;; scheduler (see multiproc.oak) to keep track of what process is currently ;; being executed on this heavyweight thread. ;; (define-constant %load-process (add-method ((make-open-coded-operation '((load-reg process)) 0 1) (object)) (%load-process))) ;; ;; Stores the variable in the "process" register. The compliment of ;; %load-process. ;; (define-constant %store-process (add-method ((make-open-coded-operation '((store-reg process)) 1 1) (object) value) (%store-process value))) ;; An atomic operation that tests the value in a locative and sets it ;; to NEW if the value is currently OLD. A boolean is returned to ;; indicate success or failure. (define-constant %test-and-set-locative (add-method ((make-open-coded-operation '((test-and-set-locative)) 3 1) (locative) loc old new) (%test-and-set-locative loc old new))) oaklisp-1.3.3.orig/src/world/cmdline.oak0000664000175000000620000000237007725515165017125 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1999 Barak A. Pearlmutter (define (get-argv i) (let aux ((rchars '()) (j 0)) (let ((c (get-argline-char i j))) (cond ((eqv? c #\nul) (#^string (reverse rchars))) ((eqv? c #f) #f) (else (aux (cons c rchars) (+ j 1))))))) (define (get-argline) (let aux ((rargv '()) (i 0)) (let ((a (get-argv i))) (if a (aux (cons a rargv) (+ i 1)) (reverse rargv))))) (define argline '()) (define (fetch-argline) (set! argline (get-argline))) (add-warm-boot-action fetch-argline) oaklisp-1.3.3.orig/src/world/export.oak0000664000175000000620000000201107725515165017023 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;;Copyright (C) 1987 Barak A. Pearlmutter & Kevin J. Lang (define (export-sharing-cell source destination variable) (let ((try (variable-here? source variable))) (if try (set! (variable-here? destination variable) try) (warning "~S not found in ~S; can't export.~%" variable source)))) oaklisp-1.3.3.orig/src/world/complex.oak0000664000175000000620000001442507725515165017165 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Complex numbers! Oh boy! ;;; (define-instance complex type '(the-real-part the-imag-part) (list number object)) (add-method (initialize (complex the-real-part the-imag-part) self x y) (set! the-real-part x) (set! the-imag-part y) self) (define (make-complex i j) (if (eq? j 0) i (make complex i j))) ;;; This controls how complex numbers are printed. ;;; ;;; Possible values are STRUCTURE, I-NOTATION, and (some day) POLAR ;;; which will cause 3+4i to print as #C(3 4), 3+4i, and (some day) ;;; 5@0.92729521. (set! #*complex-display-style 'structure) (add-method (print (complex the-real-part the-imag-part) self stream) (case #*complex-display-style ((structure) (format stream "#C(~A ~A)" the-real-part the-imag-part)) ((i-notation) (unless (zero? the-real-part) (format stream "~A" the-real-part)) (let ((im (cond ((negative? the-imag-part) (write-char stream #\-) (- the-imag-part)) (else (write-char stream #\+) the-imag-part)))) (unless (= im 1) (format stream "~A" im)) (write-char stream #\i))) ;; trig stuff is unimplemented: ;((polar) ; (format stream "~A@~A" (abs self) (phase self))) (else (error "Unknown complex printing style ~S." #*complex-display-style)))) (add-method (exact? (complex the-real-part the-imag-part) self) (and (exact? the-real-part) (exact? the-imag-part))) (define-instance real-part operation) (define-instance imag-part operation) (add-method (real-part (complex the-real-part) self) the-real-part) (add-method (imag-part (complex the-imag-part) self) the-imag-part) (add-method (real-part (number) self) self) (add-method (imag-part (number) self) 0) (define-instance abs-squared operation) (add-method (abs-squared (complex the-real-part the-imag-part) self) (+ (* the-real-part the-real-part) (* the-imag-part the-imag-part))) (add-method (abs-squared (number) x) (* x x)) (add-method (abs (complex) self) (sqrt (abs-squared self))) (add-method (plus/2 (complex the-real-part the-imag-part) x y) (make-complex (+ the-real-part (real-part y)) (+ the-imag-part (imag-part y)))) (add-method (minus (complex the-real-part the-imag-part) self) (make complex (- the-real-part) (- the-imag-part))) (define-instance conjugate operation) (add-method (conjugate (complex the-real-part the-imag-part) self) (make complex the-real-part (- the-imag-part))) (add-method (conjugate (number) self) self) (add-method (times/2 (complex the-real-part the-imag-part) x y) (efselect-type y ((complex) (let ((y-real (real-part y)) (y-imag (imag-part y))) (make-complex (- (* the-real-part y-real) (* the-imag-part y-imag)) (+ (* the-real-part y-imag) (* the-imag-part y-real))))) ((number) (make-complex (* the-real-part y) (* the-imag-part y))))) (add-method (/ (complex the-real-part the-imag-part) x y) (efselect-type y ((complex) (* (/ x (abs-squared y)) (conjugate y))) ((number) (make-complex (/ the-real-part y) (/ the-imag-part y))))) (add-method (/r (complex the-real-part the-imag-part) x y) (efselect-type y ((complex) (/ x y)) ((number) (* (/ y (abs-squared x)) (conjugate x))))) (add-method (= (complex the-real-part the-imag-part) x y) (and (= the-imag-part (imag-part y)) (= the-real-part (real-part y)))) #|| (add-method (sqrt (complex) z) (* (sqrt (abs z)) (cis (/ (phase z) 2)))) ||# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Try defining some new generic arithmetic operators: (define-instance signum operation) (add-method (signum (real) x) (cond ((= x 0) 0) ((> x 0) 1) (else -1))) (add-method (signum (complex) x) (/ x (abs x))) #|| (define pi 3.141592653589793d0) (define-instance phase operation) (add-method (phase (real) x) (cond ((= x 0) 0) ((> x 0) pi) (else (- pi)))) (add-method (phase (complex the-real-part the-imag-part) x) (atan2 the-imag-part the-real-part)) (add-method (^ (number) x y) (^r y x)) (define-instance ^r operation) (add-method (^r (float) y x) (exp (* (ln x) y))) (add-method (^r (integer) y x) (cond ((= y 1) x) ((= y 0) 1) ((< y 0) (/ 1 (^r (- y) x))) (else (let* ((y2 (quotient y 2)) (p (^r y2 x)) (p2 (* p p))) (* p2 (^r (- (- y y2) y2) x)))))) (add-method (^r (fraction) y x) (^r (#^float y) x)) (add-method (^r (complex the-real-part the-imag-part) y x) (* (^ x the-real-part) (cis (* the-imag-part (ln x))))) (define-instance exp operation) ;(add-method (exp (float) x) ; (z:exp x)) ;(add-method (exp (real) x) ; (z:exp (#^float x))) (add-method (exp (complex the-real-part the-imag-part) x) (* (exp the-real-part) (cis the-imag-part))) (define-instance cis operation) (add-method (cis (number) x) (make-complex (cos x) (sin x))) (add-method (cis (complex the-real-part the-imag-part) z) ;; cis(a+bi) = exp(i*(a+bi)) = exp(-b+ai) (* (cis the-real-part) (exp (- the-imag-part)))) (define-instance cos operation) (define-instance sin operation) (define-instance atan2 operation) (add-method (atan2 (real) y x) (efselect-type x ((real) (cl:atan (#^float y) (#^float x))) ((complex) (error "Arc Tangent in Complex case unimplemented")))) (define-instance ln operation) (add-method (ln (real) x) (cond ((> x 0) ...) ((< x 0) (make complex (ln (- x)) pi)) (else (error "Natural Log of Zero.")))) (add-method (ln (complex the-real-part the-imag-part) z) (make complex (ln (abs z)) (phase z))) ||# ;;; eof oaklisp-1.3.3.orig/src/world/math.oak0000664000175000000620000000276107725515165016447 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Barak A. Pearlmutter & Kevin J. Lang (define prime-list (labels (((prime? n) (iterate aux ((l prime-list)) (let* ((i (car l)) (n/i (quotient n i))) (cond ((< n/i i) #t) ((= (* i n/i) n) #f) (else (aux (cdr l))))))) ((primes-list n) (if (prime? n) (lcons n (primes-list (+ 1 n))) (primes-list (+ 1 n))))) (lcons 2 (primes-list 3)))) (define (factor n) (iterate step ((left n) (factors '()) (tries prime-list)) (let* ((try (car tries)) (try-square (* try try))) (cond ((= 1 left) factors) ((zero? (modulo left try)) (step (quotient left try) (cons try factors) tries)) ((> try-square left) (cons left factors)) (else (step left factors (cdr tries))))))) ;;; eof oaklisp-1.3.3.orig/src/world/file-io.oak0000664000175000000620000000334107725515165017035 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Barak A. Pearlmutter & Kevin J. Lang ;;; Oddly enough, here we do NOT define the OS specific ways to ;;; manipulate file descriptors. Rather, in this file we do the ;;; standard sexpr level filesystem interface: READ-FILE and WRITE-FILE, which ;;; read all the forms out of a file into a list and write a form to a ;;; file, respectively. (define (read-file file) (with-open-file (s file in) (read-until the-eof-token #f s))) (define (write-file file obj) (error-restart (format #f "Try writing ~S again (optionally under another name)." file) ((file file)) (with-open-file (s file out ugly) (bind ((#*print-level #f) (#*print-length #f) (#*print-radix 10) (#*print-escape #t) (#*symbol-slashification-style 't-compatible) (#*fraction-display-style 'normal)) (print obj s)))) #f) (define (dofile file op) (with-open-file (s file in) (iterate aux () (let ((x (read s))) (unless (eq? x the-eof-token) (op x) (aux)))))) ;;; eof oaklisp-1.3.3.orig/src/world/kernel1-install.oak0000664000175000000620000001127407725515165020522 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Barak A. Pearlmutter & Kevin J. Lang ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; define install-method ;;; Bugs: ;;; all offsets in this file of the form (%SLOT x) should be symbolic. ;;; ;;; ADD-METHOD should bomb on non-operations, or at least on undefineds. (set! %install-method-with-env (%allocate operation %simple-operation-length)) (set! ((%slot 1) %install-method-with-env) 0) (_add-method (%install-method-with-env (type operation-method-alist ivar-list) self op code-body env) (when (eq? op 0) (error "ADD-METHOD with operation 0! Type: ~A, Code-body: ~A, Env: ~A." self code-body env)) ;; Check the ivar maps for consistency (let ((code-ivar-map ((%slot 2) code-body))) (iterate aux ((real-ivar-map ivar-list) (check-ivar-map code-ivar-map)) (cond ((null? check-ivar-map) nil) (else (let ((x (car check-ivar-map))) (cond ((or (null? x) (eq? x (car real-ivar-map))) (aux (cdr real-ivar-map) (cdr check-ivar-map))) (else (error "Too early to remap ivars in code" x (car real-ivar-map))))))))) ;; flush the method cache (set! ((%slot 2) op) 0) ;; create and install the method (let ((the-method (%allocate %method 3))) (set! ((%slot 1) the-method) code-body) (set! ((%slot 2) the-method) env) (cond ((and (eq? self object) ((%slot 1) op)) (set! ((%slot 1) op) the-method)) (else (when (and ((%slot 1) op) (not (eq? ((%slot 1) op) 0))) ;; Toss it on to OBJECT's OPERATION-METHOD-ALIST: (set! ((%slot 7) object) (cons (cons op ((%slot 1) op)) ((%slot 7) object)))) (let ((the-ass (%assq op operation-method-alist))) (set! ((%slot 1) op) nil) (if the-ass (set! (cdr the-ass) the-method) (set! operation-method-alist (cons (cons op the-method) operation-method-alist))))))) op) (set! %install-method (%allocate operation %simple-operation-length)) (set! %install-lambda-with-env (%allocate operation %simple-operation-length)) (set! %install-lambda (%allocate operation %simple-operation-length)) (set! ((%slot 1) %install-method) 0) (set! ((%slot 1) %install-lambda-with-env) 0) (set! ((%slot 1) %install-lambda) 0) (_add-method (%install-method (object) self op code-body) (%install-method-with-env self op code-body %empty-environment)) #| (add-method (%install-lambda (object) code-body) (%install-method-with-env object (make operation) code-body %empty-environment)) (add-method (%install-lambda-with-env (object) code-body env) (%install-method-with-env object (make operation) code-body env)) |# ; note : calls to the following operations are no longer emitted by the compiler ; instead, the open coded operation %make-lambda-with-env is used. ; this new operation is defined in code-vector.oak ; also, the compiler has been changed to only use the "with-env" version ; of %install-method (add-method (%install-lambda (object) code-body) (let ((the-op (%allocate operation %simple-operation-length)) (the-method (%allocate %method 3))) (set! ((%slot 1) the-method) code-body) (set! ((%slot 2) the-method) %empty-environment) (set! ((%slot 1) the-op) the-method) the-op)) (add-method (%install-lambda-with-env (object) code-body env) (let ((the-op (%allocate operation %simple-operation-length)) (the-method (%allocate %method 3))) (set! ((%slot 1) the-method) code-body) (set! ((%slot 2) the-method) env) (set! ((%slot 1) the-op) the-method) the-op)) (set! error (%allocate operation %simple-operation-length)) (set! ((%slot 1) error) 0) (add-method (error (object) arg . rest) (%write-char #\F) (%write-char #\a) (%write-char #\t) (%write-char #\a) (%write-char #\l) (%write-char #\space) (%write-char #\b) (%write-char #\o) (%write-char #\o) (%write-char #\t) (%write-char #\space) (%write-char #\e) (%write-char #\r) (%write-char #\r) (%write-char #\o) (%write-char #\r) (%write-char #\.) (%write-char #\newline) ((%halt 69) arg)) ;;; eof oaklisp-1.3.3.orig/src/world/hash-reader.oak0000664000175000000620000002041207725515165017672 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang ;;; This file defines the # reader dispatch macro character. ;;; The hash dispatch macro character. (define-instance hash-macro-chars simple-vector 256) (define (errorful-hash-macro-reader stream char arg) (signal unknown-#-macro char arg) the-unread-object) (dotimes (c 256) (set! (nth hash-macro-chars c) errorful-hash-macro-reader)) ;;; Hash macro reader functions take three args: the stream, the ;;; character, and the argument, the number between the # and the ;;; macro char. Non-negative, NIL if none. (define-nonterminating-macro-char #\# (lambda (stream char) (iterate aux ((i nil)) (let ((c (read-char stream))) (if (digit? c 10) (aux (+ (* (or i 0) 10) (digit-value c))) (let ((c (upcase c))) (let ((p (nth hash-macro-chars (#^number c)))) (cond (p (p stream c i)) (else (signal unknown-#-macro i c) the-unread-object))))))))) (define (define-hash-macro-char char func) (set! (nth hash-macro-chars (#^number (upcase char))) func)) ;;; #*FOO reads as (FLUID FOO), like the old ^V FOO when ^V was on Symbolics & Macs ;;; #^FOO reads as (COERCER FOO), like the old ^Y FOO when ^Y was on Symbolics & Macs (define (define-quotelike-#-macro-char c sym) (define-hash-macro-char c (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) (list sym (read stream))))) (define-quotelike-#-macro-char #\* 'fluid) (define-quotelike-#-macro-char #\^ 'coercer) ;;; The #+ and #- reader conditionals. (set! #*features '()) (define-instance feature? settable-operation) (add-method (feature? (symbol) s) (memq s #*features)) (add-method ((setter feature?) (symbol) s bool) (cond (bool (if (not (memq s #*features)) (set! #*features (cons s #*features)))) ((memq s #*features) (set! #*features (setdifference #*features (list s))))) bool) (add-method (feature? (pair) x) (let ((s (car x))) (cond ((eq? s 'and) (every? feature? (cdr x))) ((eq? s 'or) (any? feature? (cdr x))) ((eq? s 'not) (when (not (null? (cddr x))) (error "~S is a bad feature specifier, as not only takes one argument." x)) (not (feature? (second x)))) (else (error "~S is an unknown feature specifier." x))))) (define-hash-macro-char #\+ (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) (if (feature? (read stream)) (read stream) (block (bind ((#*read-suppress #t)) (read stream)) the-unread-object)))) (define-hash-macro-char #\- (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) (if (feature? (read stream)) (block (bind ((#*read-suppress #t)) (read stream)) the-unread-object) (read stream)))) (set! (feature? 'oaklisp) #t) (set! (feature? 'scheme) #t) (define-hash-macro-char #\C (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) (let ((l (read stream))) (when (cddr l) (cerror "Ignore the excess components." "#~C~A is ill formed: too many components." char l)) (make-complex (car l) (cadr l))))) (define-hash-macro-char #\. (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) (eval (read stream) #*current-locale))) (define-hash-macro-char #\b (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) (bind ((#*input-base 2)) (read stream)))) (define-hash-macro-char #\o (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) (bind ((#*input-base 8)) (read stream)))) (define-hash-macro-char #\d (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) (bind ((#*input-base 10)) (read stream)))) (define-hash-macro-char #\x (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) (bind ((#*input-base 16)) (read stream)))) (define-hash-macro-char #\r (lambda (stream char arg) (iterate aux ((arg arg)) (cond ((null? arg) (aux (signal must-have-#-arg char arg))) (else (bind ((#*input-base arg)) (read stream))))))) (define-hash-macro-char #\( (lambda (stream char arg) (let* ((r (read-until #\) nil stream)) (l (length r)) (arg (or arg l))) (when (< arg l) (cerror "Ignore the excess componants." "The construct #~D~S puts more things in the vector than it is long." arg r)) (let ((v (make simple-vector arg))) (iterate aux ((i 0)(r r)(default nil)) (if (< i arg) (let ((it (if r (car r) default))) (set! (nth v i) it) (aux (+ i 1) (if r (cdr r) nil) it)) v)))))) ;;; A finite state machine augmented with a counter: (define-hash-macro-char #\| (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) (iterate aux ((level 1) (c (read-char stream))) (cond ((eq? c the-eof-token) (signal eof-in-#pipe level)) ((eq? c #\#) (let ((c (read-char stream))) (if (eq? c #\|) (aux (+ level 1) (read-char stream)) (aux level c)))) ((eq? c #\|) (let ((c (read-char stream))) (if (eq? c #\#) (if (= level 1) the-unread-object (aux (- level 1) (read-char stream))) (aux level c)))) (else (aux level (read-char stream))))))) (define-hash-macro-char #\T (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) #t)) (define-hash-macro-char #\F (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) nil)) ;;; For some T compatibility, this code deals with #[symbol "..."], and could ;;; be augmented to understand similar constructs like #57[code-vector ...]. (define-hash-macro-char #\[ (lambda (stream char arg) (let ((selector (read stream))) (cond ((hash-bracket-option selector) => (lambda (op) (op char arg selector stream))) (else (block0 (cerror "Return a value." "The #~A~A~A construct is unknown." (or arg "") char selector) (read-until #\] #f stream))))))) (let ((hash-bracket-option-alist '())) (define-instance hash-bracket-option settable-operation) (add-method (hash-bracket-option (object) x) (cond ((assq x hash-bracket-option-alist) => cdr) (else #f))) (add-method ((setter hash-bracket-option) (object) x op) (cond ((assq x hash-bracket-option-alist) => (lambda (p) (set! (cdr p) op))) (else (push hash-bracket-option-alist (cons x op)) op)))) (set! (hash-bracket-option 'symbol) (lambda (char arg selector stream) (when arg (cerror "Ignore the argument." "The #~D~A~S construct is malformed; no argument is taken." arg char selector)) (let ((l (read-until #\] #f stream))) (when (not (null? (cdr l))) (cerror "Ignore the extra stuff." "This contruct takes only one thing to coerce.")) (#^symbol (car l))))) (set! (hash-bracket-option 'delay) (lambda (char arg selector stream) (when arg (cerror "Ignore the argument." "The #~D~A~S construct is malformed; no argument is taken." arg char selector)) (destructure* (val num) (read-until #\] #f stream) (delay val)))) (define-hash-macro-char #\E (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) (let ((x (read stream))) ;; (make-exact x) x))) (define-hash-macro-char #\I (lambda (stream char arg) (when arg (signal cant-have-#-arg char arg)) (let ((x (read stream))) (cerror "Return the corresponding exact number." "Inexact numbers are not supported.") x))) ;;; eof oaklisp-1.3.3.orig/src/world/load-oaf.oak0000664000175000000620000001024507725515165017174 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Barak A. Pearlmutter & Kevin J. Lang (define (make-oa-list oaf-list) (let ((sym-vec (#^simple-vector (car oaf-list)))) (labels (((rewrite-syms clause) (let ((car-clause (car clause))) (if (> car-clause (- 5 1)) (list (- car-clause 5) (cadr clause) (nth sym-vec (caddr clause))) clause)))) (map! (lambda (blk) (list (map! rewrite-syms (triplify! (car blk))) (cadr blk))) (cadr oaf-list))))) (define (make-oaf-list oa-list) (let* ((sym-hash (make-eq-hash-table)) (counter 0) (new-list (map (lambda (blk) (list (untriplify! (map! (lambda (clause) (let ((sym (caddr clause))) (if (symbol? sym) (let ((num (or (table-entry sym-hash sym) (block0 (set! (table-entry sym-hash sym) counter) (set! counter (1+ counter)))))) (list (+ 5 (car clause)) (cadr clause) num)) clause))) (car blk))) (cadr blk))) oa-list))) (list (map! car (sort (#^list-type sym-hash) (lambda (a b) (< (cdr a)(cdr b))))) new-list))) ; these functions reverse the order of the triples ; also, they are extremely side-effecting, so watch out. (define (untriplify! inlist) (iterate step ((in inlist) (out '())) (if in (step (cdr in) (let ((carin (car in))) (set! (cdr (cdr (cdr carin))) out) carin)) out))) (define (triplify! inlist) (iterate step ((in inlist) (out '())) (if in (let* ((cddrin (cdr (cdr in))) (nxtrip (cdr cddrin))) (step nxtrip (block (set! (cdr cddrin) nil) (cons in out)))) out))) (define (dumb-read-number stream) (let* ((the-char (peek-char stream)) (sign (if (eq? the-char #\-) (block (read-char stream) -1) 1))) (iterate next ((worknum 0)) (let* ((the-char (read-char stream)) (num-val (- (%character->fixnum the-char) (#^number #\0)))) (cond ((and (>= num-val 0) (<= num-val 10)) (next (+ (* worknum 10) num-val))) ((eq? the-char #\)) (unread-char stream the-char) (* worknum sign)) ((or (eq? the-char #\space) (eq? the-char #\tab) (eq? the-char #\newline) (nth standard-read-table the-char) 'whitespace) (* worknum sign)) (else (error "~C encountered by dumb-read-number." the-char))))))) ;;; This does what its name implies, going circularly through the list ;;; of functions. (define (read-list-using-functions stream function-list) (skip-whitespace stream) (unless (eq? #\( (read-char stream)) (error "stream ~a not positioned at a list" stream)) (iterate next ((worklist '())(funlist function-list)) (skip-whitespace stream) (let ((the-char (peek-char stream))) (cond ((eq? #\) the-char) (read-char stream) (reverse! worklist)) (else (next (cons ((car funlist) stream) worklist) (cond ((cdr funlist) => identity) (else function-list)))))))) (define (read-oaf-list stream) (read-list-using-functions stream (list read (lambda (stream) ;list of body clauses (read-list-using-functions stream (list (lambda (stream) ;one body clause (read-list-using-functions stream (list (lambda (stream) ;resolution part (read-list-using-functions stream (list dumb-read-number dumb-read-number read))) (lambda (stream) ;code part (read-list-using-functions stream (list dumb-read-number)))))))))))) oaklisp-1.3.3.orig/src/world/tak.oak0000664000175000000620000000253107725515165016270 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter (define (tak x y z) (cond ((not (< y x)) z) (else (tak (tak (- x 1) y z) (tak (- y 1) z x) (tak (- z 1) x y))))) #| ;;; hacked for siod (define (tak x y z) (if (< y x) (tak (tak (- x 1) y z) (tak (- y 1) z x) (tak (- z 1) x y)) z)) |# ;;; This tests the effect of block compilation: (define (tak2 x y z) (iterate tak ((x x)(y y)(z z)) (cond ((not (< y x)) z) (else (tak (tak2 (- x 1) y z) (tak2 (- y 1) z x) (tak2 (- z 1) x y)))))) (define (macnine x) (if (> x 100) (- x 10) (macnine (macnine (+ x 11))))) oaklisp-1.3.3.orig/src/world/Makefile-vars0000664000175000000620000001160607725515165017431 0ustar barakstaff# This included makefile data is automatically # generated by make-makefile.oak, and should not # normally be edited by hand. It can be regenerated # with 'make Makefile-vars'. COLDFILES = st.oa da.oa pl.oa do.oa em.oa cold-booting.oa kernel0.oa kernel0types.oa kernel1-install.oa kernel1-funs.oa kernel1-make.oa kernel1-freeze.oa kernel1-maketype.oa kernel1-inittypes.oa kernel1-segments.oa super.oa kernel.oa patch0symbols.oa mix-types.oa operations.oa ops.oa truth.oa logops.oa consume.oa conses.oa coerce.oa eqv.oa mapping.oa fastmap.oa multi-off.oa fluid.oa vector-type.oa vl-mixin.oa numbers.oa subtypes.oa weak.oa strings.oa sequences.oa undefined.oa subprimitive.oa gc.oa tag-trap.oa code-vector.oa hash-table.oa format.oa signal.oa error.oa symbols.oa print-noise.oa patch-symbols.oa predicates.oa print.oa print-integer.oa print-list.oa reader-errors.oa reader.oa read-token.oa reader-macros.oa hash-reader.oa read-char.oa locales.oa expand.oa make-locales.oa patch-locales.oa freeze.oa bp-alist.oa describe.oa warm.oa interpreter.oa top-level.oa booted.oa dump-stack.oa file-errors.oa streams.oa cold.oa nargs.oa has-method.oa op-error.oa error2.oa error3.oa backquote.oa file-io.oa fasl.oa load-oaf.oa load-file.oa string-stream.oa list.oa catch.oa continuation.oa unwind-protect.oa bounders.oa anonymous.oa sort.oa exit.oa cmdline.oa cmdline-getopt.oa cmdline-options.oa export.oa cold-boot-end.oa COLDFILESD = cold-booting.oa kernel0.oa do.oa kernel0types.oa do.oa kernel1-install.oa do.oa kernel1-funs.oa do.oa kernel1-make.oa do.oa kernel1-freeze.oa do.oa kernel1-maketype.oa pl.oa kernel1-inittypes.oa pl.oa kernel1-segments.oa pl.oa super.oa pl.oa kernel.oa pl.oa patch0symbols.oa pl.oa mix-types.oa st.oa operations.oa st.oa ops.oa st.oa truth.oa st.oa logops.oa st.oa consume.oa st.oa conses.oa st.oa coerce.oa st.oa eqv.oa pl.oa mapping.oa pl.oa fastmap.oa pl.oa multi-off.oa em.oa fluid.oa pl.oa vector-type.oa pl.oa vl-mixin.oa pl.oa numbers.oa pl.oa subtypes.oa pl.oa weak.oa pl.oa strings.oa pl.oa sequences.oa pl.oa undefined.oa da.oa subprimitive.oa da.oa gc.oa da.oa tag-trap.oa da.oa code-vector.oa da.oa hash-table.oa da.oa format.oa da.oa signal.oa pl.oa error.oa da.oa symbols.oa da.oa print-noise.oa da.oa patch-symbols.oa da.oa predicates.oa da.oa print.oa do.oa print-integer.oa do.oa print-list.oa do.oa reader-errors.oa do.oa reader.oa do.oa read-token.oa do.oa reader-macros.oa do.oa hash-reader.oa pl.oa read-char.oa pl.oa locales.oa do.oa expand.oa do.oa make-locales.oa do.oa patch-locales.oa do.oa freeze.oa do.oa bp-alist.oa do.oa describe.oa do.oa warm.oa do.oa interpreter.oa pl.oa top-level.oa pl.oa booted.oa st.oa dump-stack.oa do.oa file-errors.oa do.oa streams.oa do.oa cold.oa do.oa nargs.oa pl.oa has-method.oa pl.oa op-error.oa pl.oa error2.oa pl.oa error3.oa pl.oa backquote.oa pl.oa file-io.oa pl.oa fasl.oa pl.oa load-oaf.oa pl.oa load-file.oa pl.oa string-stream.oa pl.oa list.oa pl.oa catch.oa da.oa continuation.oa da.oa unwind-protect.oa da.oa bounders.oa do.oa anonymous.oa pl.oa sort.oa pl.oa exit.oa pl.oa cmdline.oa da.oa cmdline-getopt.oa da.oa cmdline-options.oa da.oa export.oa st.oa st.oa st.oa cold-boot-end.oa MISCFILES = macros0.oa obsolese.oa destructure.oa macros1.oa macros2.oa icky-macros.oa define.oa del.oa promise.oa bignum.oa bignum2.oa rational.oa complex.oa rounding.oa lazy-cons.oa math.oa trace.oa apropos.oa time.oa alarm.oa multi-em.oa multiproc.oa COMPFILES = crunch.oa mac-comp-stuff.oa mac-compiler-nodes.oa mac-compiler1.oa mac-compiler2.oa mac-compiler3.oa mac-code.oa assembler.oa peephole.oa file-compiler.oa compiler-exports.oa RNRSFILES = scheme.oa scheme-macros.oa TOOLFILES = tool.oa FILESFILES = files.oa MAKEFILES = make-makefile.oa # These are gravy. The first two are our standard # benchmarks. The others are neat. GRAVY = tak.oak compile-bench.oak prolog.oak prolog-examples.oak # Special rules for the compiler's source crunch.oa:crunch.oak;$(OAK) $(OAKFLAGS) -- -locale compiler-locale -compile $* -exit mac-comp-stuff.oa:mac-comp-stuff.oak;$(OAK) $(OAKFLAGS) -- -locale compiler-locale -compile $* -exit mac-compiler-nodes.oa:mac-compiler-nodes.oak;$(OAK) $(OAKFLAGS) -- -locale compiler-locale -compile $* -exit mac-compiler1.oa:mac-compiler1.oak;$(OAK) $(OAKFLAGS) -- -locale compiler-locale -compile $* -exit mac-compiler2.oa:mac-compiler2.oak;$(OAK) $(OAKFLAGS) -- -locale compiler-locale -compile $* -exit mac-compiler3.oa:mac-compiler3.oak;$(OAK) $(OAKFLAGS) -- -locale compiler-locale -compile $* -exit mac-code.oa:mac-code.oak;$(OAK) $(OAKFLAGS) -- -locale compiler-locale -compile $* -exit assembler.oa:assembler.oak;$(OAK) $(OAKFLAGS) -- -locale compiler-locale -compile $* -exit peephole.oa:peephole.oak;$(OAK) $(OAKFLAGS) -- -locale compiler-locale -compile $* -exit file-compiler.oa:file-compiler.oak;$(OAK) $(OAKFLAGS) -- -locale compiler-locale -compile $* -exit compiler-exports.oa:compiler-exports.oak;$(OAK) $(OAKFLAGS) -- -locale compiler-locale -compile $* -exit oaklisp-1.3.3.orig/src/world/prolog-examples.oak0000664000175000000620000002250607725515165020633 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;;;;;; Copyright (C) 1993 Barak A. Pearlmutter & Kevin J. Lang (define p-member (relation ((a) (p-member ,a (,a . ,_))) ((a x) (p-member ,a (,_ . ,x)) :- (p-member ,a ,x)))) (define p-append (relation ((x) (p-append () ,x ,x)) ((a x y z) (p-append (,a . ,x) ,y (,a . ,z)) :- (p-append ,x ,y ,z)))) (define p-length (relation (() (p-length () 0)) ((a x j i) (p-length (,a . ,x) ,i) :- (p-length ,x ,j) (is ,i ,(+ j 1))))) (labels ((p-reverse3 (relation ((a) (p-reverse3 () ,a ,a) :- !) ((a x y z) (p-reverse3 (,a . ,x) ,y ,z) :- (p-reverse3 ,x (,a . ,y) ,z))))) (define p-reverse (relation ((a b) (p-reverse ,a ,b) :- (p-reverse3 ,a () ,b))))) (define p-delete (relation ((x l) (p-delete ,x (,x . ,l) ,l)) ((x y z l) (p-delete ,x (,y . ,l) (,y . ,z)) :- (p-delete ,x ,l ,z)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define parent (relation ((x y) (parent ,x ,y) :- (father ,x ,y)) ((x y) (parent ,x ,y) :- (mother ,x ,y)))) (define ancestor (relation ((x y) (ancestor ,x ,y) :- (parent ,x ,y)) ((x y z) (ancestor ,x ,z) :- (parent ,y ,z) (ancestor ,x ,y)))) (define father (relation (() (father sam julie)) (() (father ted sam)))) (define mother (relation (() (mother julie dave)) (() (mother anna julie)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define pfact (relation (() (pfact 0 1) :- !) ((n m l) (pfact ,n ,m) :- (pfact ,(- n 1) ,l) (is ,m ,(* l n))))) ;; munch([],[],[]). ;; munch([A|X],[B|Y],[[A,B]|Z]) :- munch(X,Y,Z). (define munch (relation (() (munch () () ())) ((a b x y z) (munch (,a . ,x) (,b . ,y) ((,a . ,b) . ,z)) :- (munch ,x ,y ,z)))) ;; noah([],[]). ;; noah([A,B|X],[[A,B]|Y]) :- noah(X,Y). (define noah (relation (() (noah () ())) ((a b x y) (noah (,a ,b . ,x) ((,a ,b) . ,y)) :- (noah ,x ,y)))) ;; my_member1(A,L) :- append(_,[A|_],L). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define p-member2 (relation ((a l) (p-member2 ,a ,l) :- (p-append ,_ (,a . ,_) ,l)))) ;; my_times(0,B,0) :- !. ;; my_times(A,B,C) :- D is A-1, my_times(D,B,E), C is E+B. (define ptimes (relation (() (ptimes 0 ,_ 0) :- !) ((a b c d e) (ptimes ,a ,b ,c) :- ,(set! d (- a 1)) (ptimes ,d ,b ,e) (is ,c ,(+ e b))))) ;; take_out_n(X,0,L,L) :- !. ;; take_out_n(X,N,[X|L],L1) :- M is N-1, take_out_n(X,M,L,L1). ;; take_out_n(X,N,[Y|L],[Y|L1]) :- take_out_n(X,N,L,L1). ;; splice_in_for(X,S,[],[]). ;; splice_in_for(X,S,[X|L],L1) :- splice_in_for(X,S,L,L2), append(S,L2,L1). ;; splice_in_for(X,S,[Y|L],[Y|L1]) :- splice_in_for(X,S,L,L1). ;; count_fringe([],0) :- !. ;; count_fringe([A|B],N) :- !, count_fringe(A,N1), count_fringe(B,N2), N is N1+N2. ;; count_fringe(_,1). (define count-fringe (relation (() (count-fringe () 0) :- !) ((a b n n1 n2) (count-fringe (,a . ,b) ,n) :- ! (count-fringe ,a ,n1) (count-fringe ,b ,n2) (is ,n ,(+ n1 n2))) (() (count-fringe ,_ 1)))) ;; every_third([],[]). ;; every_third([A],[A]). ;; every_third([A,_],[A]). ;; every_third([A,_,_|X],[A|Y]) :- every_third(X,Y). (define every-third (relation (() (every-third () ())) ((a) (every-third (,a) (,a))) ((a) (every-third (,a ,_) (,a))) ((a x y) (every-third (,a ,_ ,_ . ,x) (,a . ,y)) :- (every-third ,x ,y)))) ;; count_down(0,[blast_off]) :- !. ;; count_down(N,[N|X]) :- M is N-1, count_down(M,X). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; This loops after finding one solution when used in right-to-left mode. ; Putting a cut in the first clause would cause it to find no solutions. ; This behavior is consistent with quintus prolog. ; By the way, this is a standard benchmark for prolog systems, and ; and we appear to be about 1000 times slower than quintus prolog. ;; naive_reverse([],[]). ;; naive_reverse([A|X],Y) :- naive_reverse(X,X1), append(X1,[A],Y). (define naive-reverse (relation (() (naive-reverse () ())) ((a x x1 y) (naive-reverse (,a . ,x) ,y) :- (naive-reverse ,x ,x1) (p-append ,x1 (,a) ,y)))) (define weird-reverse (relation (() (weird-reverse () ())) ((a x x1 y) (weird-reverse (,a . ,x) ,y) :- (weird-reverse ,x ,x1) (oak-append ,y ,x1 (,a))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; this version works in both directions ;; good-reverse(A,B) :- good-reverse(A,[],B). ;; good-reverse([],A,A) :- !. ;; good-reverse([A|X],Y,Z) :- good-reverse(X,[A|Y],Z). (define good-reverse (relation ((a b) (good-reverse ,a ,b) :- (good-reverse3 ,a () ,b)))) (define good-reverse3 (relation ((a) (good-reverse3 () ,a ,a) :- !) ((a x y z) (good-reverse3 (,a . ,x) ,y ,z) :- (good-reverse3 ,x (,a . ,y) ,z)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; this code doesn't work from right to left, even with quintus prolog ;; bad_reverse(A,B) :- bad_reverse(A,[],B). ;; bad_reverse([],A,A). ;; bad_reverse([A|X],Y,Z) :- !, bad_reverse(A,B), bad_reverse(X,[B|Y],Z). ;; bad_reverse(X,[],X). (define bad-reverse (relation ((a b) (bad-reverse ,a ,b) :- (bad-reverse3 ,a () ,b)))) (define bad-reverse3 (relation ((a) (bad-reverse3 () ,a ,a)) ((a b x y z) (bad-reverse3 (,a . ,x) ,y ,z) :- ! (bad-reverse ,a ,b) (bad-reverse3 ,x (,b . ,y) ,z)) ((x) (bad-reverse3 ,x () ,x)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ordered([]). ;; ordered([_]). ;; ordered([A,B|X]) :- not(B (lambda (ext) (load-with-ext (file-base file) ext locale #f))) ;; Try lots of different filetypes. ((any? (lambda (ext) (load-with-ext file ext locale #t)) '(".oa" ".oak" ".omac")) => (lambda (ext) (format #t "~&Loaded ~A~A.~%" file ext))) (else (error "No loadable file ~S found.~%" file)))))))) (define (load file . args) (listify-args load-aux ((if (symbol? file) downcase identity) (#^string file)) . args))) ;;; These utility functions belong elsewhere: ;;; This includes the "." as part of the extension. (define (file-extension file) (let ((len (length file))) (iterate aux ((i (- len 1))) (if (= i -1) #f (let ((c (nth file i))) (cond ((eq? c #\.) (tail file i)) ((eq? c #\/) #f) (else (aux (- i 1))))))))) (define (file-base file) (cond ((file-extension file) => (lambda (ext) (head file (- (length file) (length ext))))) (else file))) ;;; (define (load-oa-file locale file) (load-code-segment locale (with-open-file (s (append file ".oa") in) (make-oa-list (read-oaf-list s))))) #|| (define (load-oa-file locale file) (load-code-segment locale (with-open-file (s (append (#^string file) ".oa") in) (let ((red (read s))) (if (and (pair? (car red)) (pair? (caar red))) red (make-oa-list red)))))) (define (load-oa-file locale file) (load-code-segment locale (let ((s (open-input-file (append (#^string file) ".oa")))) (block0 (read s) (close s))))) (define (load-oak-file locale file) (bind ((#*current-locale locale) (#*print-length 3) (#*print-level 2)) (dofile (append file ".oak") (lambda (expr) (format #t "~A...~%" expr) (eval expr locale))))) ||# (define (load-oak-file the-locale file-name) (let* ((raw-forms (read-file (append file-name ".oak"))) (sub-locale (make locale (list the-locale)))) (bind ((#*current-locale the-locale) (#*print-length 3) (#*print-level 2)) (dolist (raw-form raw-forms) (format #t "~A...~%" raw-form) (let ((expanded-form (bind ((#*current-locale sub-locale)) (expand-groveling sub-locale raw-form)))) (subeval expanded-form the-locale)))) 'loaded)) (define (load-omac-file locale file) (dofile (append file ".omac") (lambda (expr) (subeval expr locale)))) ;;; eof oaklisp-1.3.3.orig/src/world/make-locales.oak0000664000175000000620000000251107725515165020044 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;; currently, the locale structure looks like this: ;; ;; SYSTEM . . . OAKLISP ;; / \ ;; COMPILER USER ;; ;; ;; ;; system-locale gets filled in from the boot world by patch-locales.oak. ;; oaklisp-locale will be filled with stuff exported from system-locale. (define-instance system-locale locale '()) (define-instance compiler-locale locale (list system-locale)) (define-instance oaklisp-locale locale '()) (define-instance user-locale locale (list oaklisp-locale)) ;;; eof oaklisp-1.3.3.orig/src/world/format.oak0000664000175000000620000001706707725515165017013 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Barak A. Pearlmutter and Kevin J. Lang ;;; Formatted output. Fancy version with modularity and lots of features. ;;; Format directive syntax: ;;; ;;; ::= '~' LISTOF( { | | '' } ) [':'] ['@'] ;;; LISTOF(x) ::= { '' | { x ',' }* x } ;;; ::= ''' ;;; ::= [ '+' | '-' ] + ;;; (let ((formats (lambda (arglist) (apply format arglist) (#^string (car arglist))))) (define (format stream control-string . args) (if (null? stream) (let ((s (make string-output-stream))) (listify-args formats s control-string . args)) (formati (if (eq? stream #t) standard-output stream) control-string 0 (length control-string) . args)))) (define (formati stream control-string index limit . args) (iterate aux ((index index)) (if (< index limit) (let ((char (nth control-string index))) (cond ((eq? char #\~) (format-parse-directive stream control-string (+ index 1) limit . args)) (else (write-char stream char) (aux (+ index 1))))) (if (zero? (rest-length args)) #f (listify-args format-arg-count-error stream control-string . args))))) (define (format-arg-count-error arglist) (destructure (stream control-string . arglist) arglist (cerror "Ignore the excess arguments." "After processing ~S to ~A, ~D argument~P ~S remained unconsumed." control-string stream (length arglist) (length arglist) arglist))) (define (format-parse-directive stream control-string index limit . args) (labels ((parse-list (lambda (char index the-list) (cond ((eq? char #\,) (parse-list (nth control-string index) (+ index 1) (cons nil the-list))) ((eq? char #\') (let ((quoted-char (nth control-string index))) (eat-comma (nth control-string (+ index 1)) (+ index 2) (cons quoted-char the-list)))) ((number-starter? char) (labels ((parse-number (lambda (char index num neg?) (let ((cn (#^number char))) (cond ((and (<= (#^number #\0) cn) (<= cn (#^number #\9))) (parse-number (nth control-string index) (+ index 1) (+ (* num 10) (- cn (#^number #\0))) neg?)) (else (eat-comma char index (cons (if neg? (- num) num) the-list)))))))) (cond ((eq? char #\-) (parse-number (nth control-string index) (+ index 1) 0 #t)) ((eq? char #\+) (parse-number (nth control-string index) (+ index 1) 0 #f)) (else (parse-number char index 0 #f))))) (else (find-colon char index the-list))))) (eat-comma (lambda (char index the-list) (if (eq? char #\,) (parse-list (nth control-string index) (+ index 1) the-list) (parse-list char index the-list)))) (find-colon (lambda (char index the-list) (if (eq? char #\:) (find-atsign (nth control-string index) (+ index 1) the-list #t) (find-atsign char index the-list #f)))) (find-atsign (lambda (char index the-list colon?) (if (eq? char #\@) (terminate (nth control-string index) (+ index 1) the-list colon? #t) (terminate char index the-list colon? #f)))) (terminate (lambda (char index the-list colon? atsign?) (destructure (arg-count op) (nth format-control-table (#^number (upcase char))) (cond ((eq? 0 arg-count) (op the-list colon? atsign? char stream) (formati stream control-string index limit . args)) ((eq? 1 arg-count) (formati1 stream control-string index limit the-list colon? atsign? char op . args)) (else (error "Format control arg may be only 0 or 1."))))))) (parse-list (nth control-string index) (+ index 1) '()))) (define (formati1 stream control-string index limit the-list colon? atsign? char op arg . args) (op the-list colon? atsign? char stream arg) (formati stream control-string index limit . args)) (define (number-starter? c) (or (eq? c #\+) (eq? c #\-) (eq? c #\0) (eq? c #\1) (eq? c #\2) (eq? c #\3) (eq? c #\4) (eq? c #\5) (eq? c #\6) (eq? c #\7) (eq? c #\8) (eq? c #\9))) ;;; A general way to define format control thingies: (define-instance format-control-table simple-vector 128) (let ((x (list 1 (lambda (the-list colon? atsign? char stream arg) (error "Unknown format control character ~C, argument ~S." char arg))))) (dotimes (i 128) (set! (nth format-control-table i) x))) (define (define-format-control char arg-count lamb) (set! (nth format-control-table (#^number (upcase char))) (list arg-count lamb))) ;;; The way they work: (define-format-control #\A 1 (lambda (the-list colon? atsign? char stream arg) (bind ((#*print-escape #f)) (print arg stream)))) (define-format-control #\~ 0 (lambda (the-list colon? atsign? char stream) (write-char stream #\~))) (define-format-control #\% 0 (lambda (the-list colon? atsign? char stream) (newline stream))) (define-format-control #\& 0 (lambda (the-list colon? atsign? char stream) (freshline stream))) (define-format-control #\S 1 (lambda (the-list colon? atsign? char stream arg) (bind ((#*print-escape #t)) (print arg stream)))) (define-format-control #\B 1 (lambda (the-list colon? atsign? char stream arg) (bind ((#*print-radix 2)) (print arg stream)))) (define-format-control #\D 1 (lambda (the-list colon? atsign? char stream arg) (bind ((#*print-radix 10)) (print arg stream)))) (define-format-control #\O 1 (lambda (the-list colon? atsign? char stream arg) (bind ((#*print-radix 8)) (print arg stream)))) (define-format-control #\X 1 (lambda (the-list colon? atsign? char stream arg) (bind ((#*print-radix 16)) (print arg stream)))) (define-format-control #\R 1 (lambda (the-list colon? atsign? char stream arg) (cond ((null? the-list) (error "Roman numerals are not yet implemented.")) (else (bind ((#*print-radix (last the-list))) (print arg stream)))))) (define-format-control #\C 1 (lambda (the-list colon? atsign? char stream arg) (print arg stream))) (define-format-control #\P 1 (lambda (the-list colon? atsign? char stream arg) (if (!= arg 1) (write-char stream #\s)))) (define-format-control #\! 1 (lambda (the-list colon? atsign? char stream arg) (cond ((and #*fancy-references (reasonable-expression #*current-locale arg)) => (lambda (expr) (format stream "~S " expr)))) (bind ((#*print-radix 10)) (print (object-hash arg) stream)))) ;;; This can't be CL compatible, because it has no way to communicate a new ;;; index back to the main routine. ;;; ;;; Ultimately, this should ignore whitespace following the newline. (define-format-control #\newline 0 (lambda (the-list colon? atsign? char stream) )) ;;; eof oaklisp-1.3.3.orig/src/world/Makefile0000664000175000000620000000616410752642641016455 0ustar barakstaff# This file is part of Oaklisp. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html # or from the Free Software Foundation, 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA # This value of prefix will usually be overridden prefix=/usr/local # Bigendian machines need bigendian binary oaklisp worlds, so non-cold # worlds are only compatible across machines of the same endianity. all: oakworld.bin -include Makefile-vars ALLOAFILES += $(TOOLFILES) ALLOAFILES += $(MAKEFILES) ALLOAFILES += $(FILESFILES) ALLOAFILES += $(COLDFILES) ALLOAFILES += $(MISCFILES) ALLOAFILES += $(COMPFILES) ALLOAFILES += $(RNRSFILES) SOURCE = $(ALLOAFILES:.oa=.oak) Makefile # The Oaklisp emulator executable. # Use "OAK=oaklisp" unless compiling new emulator. OAK = ../emulator/oaklisp # Flags for the emulator. # When bootstrapping add "OAKFLAGS+=--world ...../oakworld.bin" OAKFLAGS = --trace-gc=1 # How to compile oaklisp source files into oaklisp bytecode object files: .SUFFIXES: .oa .oak %.oa : %.oak ; $(OAK) $(OAKFLAGS) -- --compile $* --exit # How to build a new cold world using the world builder tool: new.cold: $(COLDFILES) $(TOOLFILES) -rm -f new.cold new.sym $(OAK) $(OAKFLAGS) \ -- \ --load tool \ --eval "(tool-files '($(COLDFILESD:.oa=)) 'new)" \ --exit # How to boot cold world into warm world: oakworld-1.bin: new.cold $(OAK) $(OAKFLAGS) --world new.cold --dump $@ # load successive layers of functionality onto the world oakworld-2.bin: oakworld-1.bin $(MISCFILES) $(OAK) $(OAKFLAGS) --world oakworld-1.bin --dump $@ \ -- \ $(foreach f, $(MISCFILES:.oa=),--load $(f)) \ --exit oakworld-3.bin: oakworld-2.bin $(COMPFILES) $(OAK) $(OAKFLAGS) --world oakworld-2.bin --dump $@ \ -- \ --locale compiler-locale \ $(foreach f, $(COMPFILES:.oa=),--load $(f)) \ --locale system-locale --exit oakworld.bin: oakworld-3.bin $(RNRSFILES) $(OAK) $(OAKFLAGS) --world oakworld-3.bin --dump $@ \ -- \ --eval '(define-instance scheme-locale locale (list system-locale))'\ --locale scheme-locale \ $(foreach f, $(RNRSFILES:.oa=),--load $(f)) \ --locale system-locale --exit # How to rebuild variables included by this Makefile itself: Makefile-vars: $(MAKEFILES) $(FILESFILES) $(OAK) $(OAKFLAGS) \ -- \ --load files --load make-makefile --eval '(make-makefile "$@")' \ --exit d=$(DESTDIR)$(prefix)/lib/oaklisp .PHONY: install install: oakworld.bin mkdir --parents $d cp -a $^ $d/ .PHONY: clean clean: clean-oa-files -rm -f oakworld{-1,-2,-3}.bin new.cold new.sym .PHONY: clean-oa-files clean-oa-files: -rm -f $(ALLOAFILES) .PHONY: reallyclean reallyclean: clean -rm -f oakworld.bin oaklisp-1.3.3.orig/src/world/cold-boot-end.oak0000664000175000000620000000351707725515165020144 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988, Kevin J. Lang & Barak A. Pearlmutter ;;; This file goes at the end of the cold boot. ;;; Turn off the annoying alliterative ampersands. (set! monitor-for-bruce #f) ;;; Turn off the cold load streams so the whole concept will get GCed. (set! standard-input 0) (set! standard-output 0) (%write-char #\newline) (%write-char #\C) (%write-char #\o) (%write-char #\l) (%write-char #\d) (%write-char #\space) (%write-char #\b) (%write-char #\o) (%write-char #\o) (%write-char #\t) (%write-char #\e) (%write-char #\d) (%write-char #\.) (%write-char #\newline) (%write-char #\newline) (%write-char #\O) (%write-char #\a) (%write-char #\k) (%write-char #\l) (%write-char #\i) (%write-char #\s) (%write-char #\p) (%write-char #\space) (%write-char #\s) (%write-char #\t) (%write-char #\o) (%write-char #\p) (%write-char #\p) (%write-char #\e) (%write-char #\d) (%write-char #\space) (%write-char #\i) (%write-char #\t) (%write-char #\s) (%write-char #\e) (%write-char #\l) (%write-char #\f) (%write-char #\.) (%write-char #\.) (%write-char #\.) (%write-char #\newline) ;;; Halt so the world will dump. ((%halt 0)) ;;; eof oaklisp-1.3.3.orig/src/world/mapping.oak0000664000175000000620000004512507725515165017152 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Define some mapping functions and stuff: ;; ;;; These guys are generic; see definitions in sequences.oak. (define-instance head locatable-operation) (define-instance tail locatable-operation) (define-instance last locatable-operation) (define-instance last-pair operation) (add-method (last (pair) self) (car (last-pair self))) (add-method ((locater nth) (pair) self n) (iterate aux ((self self) (n n)) (cond ((zero? n) (make-locative (car self))) ((negative? n) (error "Negative index to (LOCATER NTH).")) (else (aux (cdr self) (- n 1)))))) (add-method ((setter nth) (pair) self n new-value) (set! (contents (make-locative (nth self n))) new-value)) (add-method (nth (pair) self n) (iterate aux ((self self) (n n)) (cond ((zero? n) (car self)) ((negative? n) (error "Negative index to (LOCATER NTH).")) (else (aux (cdr self) (- n 1)))))) (add-method ((locater tail) (pair) self n) (cond ((< n 1) (error "Illegal index to LOCATER TAIL of a list.")) ((= n 1) (make-locative (cdr self))) (else (make-locative (tail (cdr self) (- n 1)))))) (add-method ((setter tail) (pair) self n new-value) (set! (contents (make-locative (tail self n))) new-value)) (add-method (tail (list-type) self n) (iterate aux ((self self) (n n)) (cond ((zero? n) self) (else (aux (cdr self) (- n 1)))))) (add-method ((locater last) (pair) self) (make-locative (car (last-pair self)))) (add-method (last-pair (pair) self) (cond ((pair? (cdr self)) (last-pair (cdr self))) (else self))) (add-method ((setter length) (pair) self new-len) (set! (tail self new-len) nil) new-len) ;;; How to copy lists: ;;; NOTE This is not optimal. We could use make to make an empty list and ;;; then fill it with an iterate, avoiding all these funcalls. (add-method (copy (pair) self) (cons (car self) (copy (cdr self)))) (add-method (copy (null-type) self) nil) (add-method (copy (object) self) self) ;;; EQUAL? (add-method (equal? (pair) x y) (or (eq? x y) (and (pair? y) (equal? (car x) (car y)) (equal? (cdr x) (cdr y))))) (add-method (equal? (object) x y) (eq? x y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-instance map operation) (define-instance map1 operation) (define-instance map2 operation) (define-instance map3 operation) (define-instance map4 operation) (define-instance map5 operation) (define-instance general-map operation) (define-instance mapcdr operation) (define-instance for-each operation) (define-instance for-each1 operation) (define-instance for-each2 operation) (define-instance for-each3 operation) (define-instance for-each4 operation) (define-instance for-each5 operation) (define-instance general-for-each operation) (define-instance for-each-cdr operation) (define-instance map! operation) (add-method (mapcdr (operation) op l) (cond ((null? l) '()) (else (cons (op l) (mapcdr op (cdr l)))))) (add-method (map (operation) op l . args) ((cond ((= 0 (rest-length args)) map1) ((= 1 (rest-length args)) map2) ((= 2 (rest-length args)) map3) ((= 3 (rest-length args)) map4) ((= 4 (rest-length args)) map5) (else general-map)) op l . args)) (add-method (map1 (operation) op l) (cond ((null? l) '()) (else (let ((x (op (car l)))) (cons x (map1 op (cdr l))))))) (add-method (map2 (operation) op l1 l2) (cond ((null? l1) '()) (else (let ((x (op (car l1) (car l2)))) (cons x (map2 op (cdr l1) (cdr l2))))))) (add-method (map3 (operation) op l1 l2 l3) (cond ((null? l1) '()) (else (let ((x (op (car l1) (car l2) (car l3)))) (cons x (map3 op (cdr l1) (cdr l2) (cdr l3))))))) (add-method (map4 (operation) op l1 l2 l3 l4) (cond ((null? l1) '()) (else (let ((x (op (car l1) (car l2) (car l3) (car l4)))) (cons x (map4 op (cdr l1) (cdr l2) (cdr l3) (cdr l4))))))) (add-method (map5 (operation) op l1 l2 l3 l4 l5) (cond ((null? l1) '()) (else (let ((x (op (car l1) (car l2) (car l3) (car l4) (car l5)))) (cons x (map5 op (cdr l1) (cdr l2) (cdr l3) (cdr l4) (cdr l5))))))) (labels (((aux args) (destructure (op . args) args (aux1 op args))) ((aux1 op list-of-lists) (cond ((null? (car list-of-lists)) '()) (else (cons (apply op (map car list-of-lists)) (aux1 op (map cdr list-of-lists))))))) (add-method (general-map (operation) op . lists) (listify-args aux op . lists))) (define-instance map-and-reverse operation) (define-instance map-and-reverse1 operation) (define-instance map-and-reverse2 operation) (define-instance map-and-reverse3 operation) (define-instance map-and-reverse4 operation) (define-instance map-and-reverse5 operation) (define-instance general-map-and-reverse operation) (add-method (map-and-reverse (operation) op l . args) ((cond ((= 0 (rest-length args)) map-and-reverse1) ((= 1 (rest-length args)) map-and-reverse2) ((= 2 (rest-length args)) map-and-reverse3) ((= 3 (rest-length args)) map-and-reverse4) ((= 4 (rest-length args)) map-and-reverse5) (else general-map-and-reverse)) op '() l . args)) (add-method (map-and-reverse1 (operation) op a l) (cond ((null? l) a) (else (map-and-reverse1 op (cons (op (car l)) a) (cdr l))))) (add-method (map-and-reverse2 (operation) op a l1 l2) (cond ((null? l1) a) (else (map-and-reverse2 op (cons (op (car l1) (car l2)) a) (cdr l1) (cdr l2))))) (add-method (map-and-reverse3 (operation) op a l1 l2 l3) (cond ((null? l1) a) (else (map-and-reverse3 op (cons (op (car l1) (car l2) (car l3)) a) (cdr l1) (cdr l2) (cdr l3))))) (add-method (map-and-reverse4 (operation) op a l1 l2 l3 l4) (cond ((null? l1) a) (else (map-and-reverse4 op (cons (op (car l1) (car l2) (car l3) (car l4)) a) (cdr l1) (cdr l2) (cdr l3) (cdr l4))))) (add-method (map-and-reverse5 (operation) op a l1 l2 l3 l4 l5) (cond ((null? l1) a) (else (map-and-reverse5 op (cons (op (car l1) (car l2) (car l3) (car l4) (car l5)) a) (cdr l1) (cdr l2) (cdr l3) (cdr l4) (cdr l5))))) (labels (((aux args) (destructure (op a . args) args (aux1 op a args))) ((aux1 op a list-of-lists) (cond ((null? (car list-of-lists)) a) (else (aux1 op (cons (apply op (map-and-reverse car list-of-lists)) a) (map cdr list-of-lists)))))) (add-method (general-map-and-reverse (operation) op a . lists) (listify-args aux op a . lists))) (add-method (for-each (operation) op l . args) ((cond ((= 0 (rest-length args)) for-each1) ((= 1 (rest-length args)) for-each2) ((= 2 (rest-length args)) for-each3) ((= 3 (rest-length args)) for-each4) ((= 4 (rest-length args)) for-each5) (else general-for-each)) op l . args)) (add-method (for-each1 (operation) op l) (if l (block (op (car l)) (for-each1 op (cdr l))))) (add-method (for-each2 (operation) op l1 l2) (if l1 (block (op (car l1) (car l2)) (for-each2 op (cdr l1) (cdr l2))))) (add-method (for-each3 (operation) op l1 l2 l3) (if l1 (block (op (car l1) (car l2) (car l3)) (for-each3 op (cdr l1) (cdr l2) (cdr l3))))) (add-method (for-each4 (operation) op l1 l2 l3 l4) (if l1 (block (op (car l1) (car l2) (car l3) (car l4)) (for-each4 op (cdr l1) (cdr l2) (cdr l3) (cdr l4))))) (add-method (for-each5 (operation) op l1 l2 l3 l4 l5) (if l1 (block (op (car l1) (car l2) (car l3) (car l4) (car l5)) (for-each5 op (cdr l1) (cdr l2) (cdr l3) (cdr l4) (cdr l5))))) (add-method (for-each-cdr (operation) op l) (if l (block (op l) (for-each-cdr op (cdr l))))) (add-method (map! (operation) op l) (cond ((null? l) '()) (else (set! (car l) (op (car l))) (map! op (cdr l)) l))) (define-instance every? operation) (add-method (every? (operation) pred? l) (iterate aux ((l l)) (if (null? l) #t (let ((cdrl (cdr l))) (if (null? cdrl) ;; Carefully tail recurse: (pred? (car l)) (and (pred? (car l)) (aux cdrl))))))) ;;; True if any element of l passes pred?: (define any? (make operation)) (add-method (any? (operation) pred? l) (cond ((null? l) nil) ;; Carefully tail recurse ((null? (cdr l)) (pred? (car l))) (else (or (pred? (car l)) (any? pred? (cdr l)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-instance ass operation) (define-instance rass operation) (define-instance assq operation) (define-instance assv operation) (define-instance assoc operation) (define-instance rassq operation) (define-instance mem operation) (define-instance del! operation) (define-instance del operation) (define-instance cdr-ass locatable-operation) (define-instance cdr-assq locatable-operation) (define memq (lambda (x seq) (mem eq? x seq))) (define memv (lambda (x seq) (mem eqv? x seq))) (define member (lambda (x seq) (mem equal? x seq))) (define delq (lambda (x seq) (del eq? x seq))) (define delq! (lambda (x seq) (del! eq? x seq))) (add-method (mem (operation) pred ob l) (cond ((null? l) '()) ((pred ob (car l)) l) (else (mem pred ob (cdr l))))) (add-method (del! (operation) pred ob inlist) (let ((outlist (cons 'a inlist))) (iterate step ((kons outlist)) (if (set! (cdr kons) (mem (lambda (x y) (not (pred x y))) ob (cdr kons))) (step (cdr kons)))) (cdr outlist))) #| (add-method (del (operation) pred ob inlist) (iterate loop ((in inlist)(out '())) (if (null? in) (reverse out) (if (pred ob (car in)) (loop (cdr in) out) (loop (cdr in) (cons (car in) out)))))) |# (add-method (del (operation) pred ob inlist) (let ((list-head (cons '() '()))) (iterate next ((inlist inlist)(last-newpair list-head)) (if (null? inlist) (cdr list-head) (if (pred ob (car inlist)) (next (cdr inlist) last-newpair) (let ((newpair (cons (car inlist) '()))) (set! (cdr last-newpair) newpair) (next (cdr inlist) newpair))))))) (add-method (ass (operation) pred ob l) (cond ((null? l) '()) ((pred ob (caar l)) (car l)) (else (ass pred ob (cdr l))))) (add-method (rass (operation) pred ob l) (cond ((null? l) '()) ((pred ob (cdar l)) (car l)) (else (rass pred ob (cdr l))))) (add-method (assq (object) key l) (ass eq? key l)) (add-method (assv (object) key l) (ass eqv? key l)) (add-method (assoc (object) key l) (ass equal? key l)) (add-method (rassq (object) key l) (rass eq? key l)) (add-method (cdr-ass (operation) pred ob l) (cdr (ass pred ob l))) (add-method ((setter cdr-ass) (operation) pred ob l new) (let ((entry (ass pred ob l))) (if entry (set! (cdr entry) new) (error "No association to set.")))) (add-method ((locater cdr-ass) (operation) pred ob l) (let ((entry (ass pred ob l))) (if entry (make-locative (cdr entry)) (error "No association to locate.")))) (add-method (cdr-assq (object) ob l) (cdr-ass eq? ob l)) (add-method ((setter cdr-assq) (object) ob l new) ((setter cdr-ass) eq? ob l new)) (add-method ((locater cdr-assq) (object) ob l) ((locater cdr-ass) eq? ob l)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; List manipulation (add-method (reverse (list-type) self) (iterate aux ((new '()) (old self)) (if (null? old) new (aux (cons (car old) new) (cdr old))))) (add-method (reverse! (list-type) self) (iterate aux ((old self) (new nil)) (cond (old (let ((o (cdr old))) (set! (cdr old) new) (aux o old))) (else new)))) (define-instance append operation) (define-instance append! operation) #| ; replaced by new definitions that ; take a variable number of arguments (add-method (append (pair) a b) (cons (car a) (append (cdr a) b))) (add-method (append (null-type) a b) b) (add-method (append! (pair) a b) (let ((x (last-pair a))) (set! (cdr x) b) a)) (add-method (append! (null-type) a b) b) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (labels (((append-aux1 a) a) ((append-aux2 oldcopy b) (cond ((null? oldcopy) b) ((pair? oldcopy) (let ((newcopy (cons (car oldcopy) b))) (iterate next ((oldpair (cdr oldcopy))(last-newpair newcopy)) (if (not (null? oldpair)) (next (cdr oldpair) (set! (cdr last-newpair) (cons (car oldpair) b))) newcopy)))) ((subtype? (get-type oldcopy) forcible) (append-aux2 (force oldcopy) b)) (else (append-type-error "list" oldcopy)))) ((append-aux3 a b c) (append-aux2 a (append-aux2 b c))) ((append-aux4 a b c d) (append-aux2 a (append-aux2 b (append-aux2 c d)))) ((append-aux-gen inlist) (iterate step ((in (cdr inlist)) (out (car inlist))) (if (not (null? in)) (step (cdr in) (append-aux2 (car in) out)) out)))) ; after the old definitions have been removed from the source code, ; the following two methods can be replaced by one for list-type (add-method (append (pair) . rest) (cond ((= 2 (rest-length rest)) (append-aux2 . rest)) ((= 3 (rest-length rest)) (append-aux3 . rest)) ((= 4 (rest-length rest)) (append-aux4 . rest)) ((< 4 (rest-length rest)) (backwards-listify-args append-aux-gen . rest)) ((= 1 (rest-length rest)) (append-aux1 . rest)) (else (error "internal error: append received ~a args" (rest-length rest))))) (add-method (append (null-type) an-empty-list . rest) (cond ((= 2 (rest-length rest)) (append-aux2 . rest)) ((= 3 (rest-length rest)) (append-aux3 . rest)) ((= 4 (rest-length rest)) (append-aux4 . rest)) ((< 4 (rest-length rest)) (backwards-listify-args append-aux-gen . rest)) ((= 1 (rest-length rest)) (append-aux1 . rest)) ((= 0 (rest-length rest)) '()) (else (error "internal error: append received ~a args" (rest-length rest))))) ) (labels (((append!-aux1 a) a) ((append!-aux2 a b) (if (null? a) b (let ((x (last-pair a))) (set! (cdr x) b) a))) ((append!-aux3 a b c) (append!-aux2 a (append!-aux2 b c))) ((append!-aux-gen inlist) (iterate step ((in (cdr inlist)) (out (car inlist))) (if (not (null? in)) (step (cdr in) (append!-aux2 (car in) out)) out)))) ; after the old definitions have been removed from the source code, ; the following two methods can be replaced by one for list-type (add-method (append! (pair) . rest) (cond ((= 2 (rest-length rest)) (append!-aux2 . rest)) ((= 3 (rest-length rest)) (append!-aux3 . rest)) ((= 1 (rest-length rest)) (append!-aux1 . rest)) (else (backwards-listify-args append!-aux-gen . rest)))) (add-method (append! (null-type) an-empty-list . rest) (cond ((= 2 (rest-length rest)) (append!-aux2 . rest)) ((= 3 (rest-length rest)) (append!-aux3 . rest)) ((= 1 (rest-length rest)) (append!-aux1 . rest)) ((= 0 (rest-length rest)) '()) (else (backwards-listify-args append!-aux-gen . rest)))) ) ; Unless there are zero arguments, calls to append that invoke ; the method for object will call the error handling system, which ; will force delayed values if necessary, or else report an error. (dolist (x (list append append!)) (add-method (x (object) . rest) (if (zero? (rest-length rest)) '() (listify-args (lambda (args) (bind ((#*fancy-references #t)) (failed-funcall (cons x args)))) . rest)))) ;;; Consider removing this type checking later. (define (append-type-error type-name offending-value) (bind ((#*fancy-references #t)) (error "the append method for ~A cannot handle its second argument ~A" type-name offending-value))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Lists as sets: (define-instance union operation) (add-method (union (list-type) a b) (cond ((null? a) b) ((memq (car a) b) (union (cdr a) b)) (else (union (cdr a) (cons (car a) b))))) (define-instance intersection operation) (add-method (intersection (list-type) a b) (iterate aux ((rest a)(answer nil)) (cond ((null? rest) answer) ((memq (car rest) b) (aux (cdr rest) (cons (car rest) answer))) (else (aux (cdr rest) answer))))) (define-instance setdifference operation) (add-method (setdifference (list-type) a b) (cond ((null? a) nil) ((memq (car a) b) (setdifference (cdr a) b)) (else (cons (car a) (setdifference (cdr a) b))))) (define-instance setxor operation) (add-method (setxor (list-type) a b) (cond ((null? a) b) ((null? b) a) ((memq (car a) b) (setxor (cdr a) (del eq? (car a) b))) (else (cons (car a) (setxor (cdr a) b))))) (define-instance setequal? operation) ;;; This definition is inefficient. (add-method (setequal? (list-type) a b) (null? (setxor a b))) (define-instance subset? operation) (add-method (subset? (null-type) a b) #t) (add-method (subset? (list-type) a b) (and (memq (car a) b) (subset? (cdr a) b))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; This is used by the thing that remaps the ivar references in ;;; code blocks: (define (position-in-list x l) (iterate aux ((l l) (i 0)) (cond ((null? l) nil) ((eq? x (car l)) i) (else (aux (cdr l) (+ i 1)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; make REMOVE-METHOD, an analogue to ADD-METHOD, in terms of ;;; LOCAL-METHOD, an access operation for types' methods. ;;; #|| (define-instance local-method settable-operation) (let ((local-method0 (make settable-operation))) (add-method (local-method (operation) op typ) (local-method0 typ op)) (add-method (local-method0 (type operation-method-alist) typ op) (let ((pair (%assq op operation-method-alist))) (if meth (cdr meth) nil))) (add-method ((setter local-method) (operation) op typ new-method) (set! (local-method0 typ op) new-method)) (add-method ((setter local-method0) (type operation-method-alist) typ op new-method) (cond ((null? new-method) (let ((meth (%assq op operation-method-alist))) (if meth (set! operation-method-alist (set-difference local-method (list meth)))))) (else (set! local-method (cons (cons op new-method) operation-method-alist)))) new-method) ) (define-instance remove-method operation) (add-method (remove-method (operation) op typ) (set! (local-method op typ) nil)) ||# ;;; eof oaklisp-1.3.3.orig/src/world/rounding.oak0000664000175000000620000000340107725515165017333 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter ;;; The rounding stuff from R3RS. (define-instance floor operation) (define-instance ceiling operation) (define-instance truncate operation) (define-instance round operation) (dolist (op (list floor ceiling truncate round)) (add-method (op (integer) x) x)) (add-method (floor (fraction the-numerator the-denominator) x) (quotientm the-numerator the-denominator)) (add-method (ceiling (fraction the-numerator the-denominator) x) (+ (quotientm the-numerator the-denominator) 1)) (add-method (truncate (fraction the-numerator the-denominator) x) (quotient the-numerator the-denominator)) ;;; This rounds to the nearest integer, breaking ties by rounding to even: (add-method (round (fraction the-numerator the-denominator) x) (let ((f (quotientm the-numerator the-denominator))) (cond ((= the-denominator 2) ;; round to even: (if (even? f) f (+ 1 f))) (else (let ((m (modulo the-numerator the-denominator))) (if (< (+ m m) the-denominator) f (+ 1 f))))))) ;;; eof oaklisp-1.3.3.orig/src/world/file-compiler.oak0000664000175000000620000001100107725515165020230 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Kevin J. Lang and Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; file compiler ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (set! canonical-extension-numbers '((".oak" . 0) (".omac" . 1) (".ou" . 2) (".oc" . 3) (".oa" . 4))) (define (canexno ex) (cdr (assoc ex canonical-extension-numbers))) (set! compiler-from-extension ".oak") (set! compiler-to-extension ".oa") ;;; valid values: 0, 1 or 2. (define #*compiler-noisiness 1) (set! #*compiling-a-file? #f) (define (print-appropriate-noise form) (when (> #*compiler-noisiness 0) (bind ((#*print-length 3) (#*print-level 2)) (format #t "~&~A" form) (flush standard-output)))) (define (print-sp x) (when (> #*compiler-noisiness 1) (format #t " ~A" x) (flush standard-output))) (define (include-stage? from-no to-no this) (let ((this-no (canexno this))) (and (< from-no this-no) (>= to-no this-no)))) ;;; The next three functions are the exported interface to the compiler. (define (compile-file the-locale file-name) (let ((from-no (canexno compiler-from-extension)) (to-no (canexno compiler-to-extension)) (sub-locale (make locale (list the-locale)))) ;; (format #t "from: ~a to: ~a~%" from-no to-no) (let ((s1 (if (include-stage? from-no to-no ".omac") (lambda (form) (block0 (bind ((#*current-locale sub-locale)) (expand-groveling sub-locale form)) (print-sp 'macro))) identity)) (s2 (if (include-stage? from-no to-no ".ou") (lambda (form) (block0 (append! (bind ((#*compiling-a-file? #t)) (gen-code (compile the-locale form) 'next)) (list '(pop 1))) (print-sp 'code))) identity)) (s2b (if (include-stage? from-no to-no ".ou") (lambda (forms) `(code () ,(append! (splice forms) (list '(return))))) identity)) (after-reading (if (>= from-no (canexno ".ou")) car identity)) (s3 (if (include-stage? from-no to-no ".oc") (lambda (form) (destructure* ('code () form) form (when (> #*compiler-noisiness 1) (format #t "Peephole optimizing... ") (flush standard-output)) `(code () ,(peephole-optimize form)))) identity)) (s4 (if (include-stage? from-no to-no ".oa") (lambda (form) (make-oaf-list (assemble form))) identity))) (let ((s12 (if (or (not (eq? s1 identity)) (not (eq? s2 identity))) (lambda (forms) (map (lambda (form) (block (print-appropriate-noise form) (block0 (s2 (s1 form)) (when (> #*compiler-noisiness 0) (format #t "~%"))))) forms)) identity))) (write-file (append file-name compiler-to-extension) (block0 (s4 (s3 (s2b (s12 (after-reading (read-file (append file-name compiler-from-extension))))))) (when (> #*compiler-noisiness 1) (format #t " writing...") (flush standard-output)))) (when (> #*compiler-noisiness 0) (format #t "~&")) #f)))) (define (compiler-eval form locale) ((%install-lambda (link-code-segment locale (assemble `(code () ;; The (POP 1) is needed because of the check-nargs hack. ((pop 1) ,@(peephole-optimize (bind ((#*compiling-a-file? #f)) (gen-code (compile locale form) 'tail)))))))))) (define (cc x) (peephole-optimize (bind ((#*compiling-a-file? #f)) (gen-code (expand-compile #*current-locale x) 'tail)))) (define (compile-code-fragment which-locale sexpr continuation-code) (peephole-optimize (gen-code (expand-compile which-locale sexpr) continuation-code))) ;;; More non-exported stuff: (set! #*top-level-evaluator hybrid-eval) ;;; eof oaklisp-1.3.3.orig/src/world/macros2.oak0000664000175000000620000001345607725515165017067 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang and Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; macros (second chunk) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-syntax (create-accessors typ prefix . vars) `(block ,@(map (lambda (x) (let ((pre-x (#^symbol (append (#^string prefix) (#^string x))))) `(block (set! ,pre-x (make operation)) (add-method (,pre-x (,typ ,x) self) ,x)))) vars))) (define-syntax (create-setters typ prefix . vars) `(block ,@(map (lambda (x) (let ((pre-x (#^symbol (append (#^string prefix) (#^string x))))) `(block (set! ,pre-x (make settable-operation)) (add-method (,pre-x (,typ ,x) self) ,x) (add-method ((setter ,pre-x) (,typ ,x) self val) (set! ,x val))))) vars))) (define-syntax (create-locaters typ prefix . vars) (let ((the-type (genvar))) `(let ((,the-type ,typ)) ,@(map (lambda (x) (let ((pre-x (#^symbol (append (#^string prefix) (#^string x))))) `(block (set! ,pre-x (make locatable-operation)) (add-method (,pre-x (,the-type ,x) self) ,x) (add-method ((locater ,pre-x) (,the-type ,x) self) (make-locative ,x)) (add-method ((setter ,pre-x) (,the-type ,x) self val) (set! ,x val))))) vars)))) (define-syntax (with-operations names . body) `(let ,(map (lambda (x) `(,x (make operation))) names) ,@body)) ;This makes things like frozen-here? by doing things like ;(define-set-manager frozen-here? locale frozen-symbols) (define-syntax (define-set-manager pred typ ivar) (let ((element (genvar)) (newstatus (genvar))) `(block (define-instance ,pred settable-operation) (add-method (,pred (,typ ,ivar) self ,element) (memq ,element ,ivar)) (add-method ((setter ,pred) (,typ ,ivar) self ,element ,newstatus) (if ,newstatus (if (not (memq ,element ,ivar)) (set! ,ivar (cons ,element ,ivar))) (set! ,ivar (delq ,element ,ivar))) ,newstatus)))) (define-syntax (push location expr) (if (symbol? location) `(set! ,location (cons ,expr ,location)) `(let ((loc (make-locative ,location))) (set! (contents loc) (cons ,expr (contents loc)))))) (define-syntax (pop location) (if nil;; (symbol? location), but can't check if it's a stack var... `(prog0 (car location) (set! location (cdr location))) `(let* ((loc (make-locative ,location)) (val (contents loc))) (set! (contents loc) (cdr val)) (car val)))) (define-syntax (swap loc1 loc2) `(let ((l1 (make-locative ,loc1)) (l2 (make-locative ,loc2))) (let ((v1 (contents l1))) (set! (contents l1) (contents l2)) (set! (contents l2) v1)))) (let ((option-set-alist '( ((in) . open-input-file) ((out) . open-output-file) ((append) . open-output-file-append) ((out ugly) . open-output-file-ugly) ((append ugly) . open-output-file-append-ugly) ))) (define-syntax (with-open-file (var file . options) . body) `(let ((,var (,(cdr (ass setequal? options option-set-alist)) ,file))) (wind-protect () (block ,@body) (close ,var))))) (define-syntax (with-input-from-string (var str) . body) `(let ((,var (make string-input-stream ,str))) ,@body)) (define-syntax (modify-location place proc) (labels ((normal (lambda (place) `((setter contents) (make-locative ,place) (,proc ,place))))) (if (symbol? place) (normal place) (let ((place (expand-groveling #*current-locale place))) (if (symbol? place) (normal place) (let ((varlist (map (lambda (x) (genvar)) place))) `(let ,(map list varlist place) (set! ,varlist (,proc ,varlist))))))))) ;;; Mutant BLOCK that captures nested DEFINE forms and mutates into ;;; a big LABELS form. ;;; Implementation: skim the DEFINEs off the top, separating the ;;; lambda's from the non-lambdas. Outer LET binds the non-lambda's ;;; to their external values. Then a LABELS sets up the lambda ones. ;;; Then destructuve assignments give all the non-lambda ones their ;;; new values. (define-syntax (mit-block . body) (iterate aux ((body body) (rvdefs '()) (rldefs '())) (destructure** body (( ('define (func . args) . def) . body) (aux body rvdefs (cons `(,func (lambda ,args ,@def)) rldefs))) (( ('define func ('lambda args . def)) . body) (aux body rvdefs (cons `(,func (lambda ,args ,@def)) rldefs))) (( ('define var val) . body) (aux body (cons `(,var ,val) rvdefs) rldefs)) (( ('define . a) . b) (error "Malformed definition ~S before ~S." `(define ,@a) b)) (otherwise (let* ((inner `(%block ,@(map (lambda (vdef) `(set! ,@vdef)) (reverse rvdefs)) ,@body)) (mid (if (null? rldefs) inner `(labels ,rldefs ,inner))) (outer (if (null? rvdefs) mid `(let ,(map (lambda (vc) `(,(car vc) (make undefined ',(car vc)))) rvdefs) ,mid)))) outer))))) ;;; eof oaklisp-1.3.3.orig/src/world/compiler-exports.oak0000664000175000000620000000206207725515165021024 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1999 Barak A. Pearlmutter & Kevin J. Lang ;;; The last two variables exported might already be in system-locale ;;; due to forward references; hence the check. (dolist (v '(cc compile-file compile-code-fragment)) (when (not (variable-here? system-locale v)) (export-sharing-cell compiler-locale system-locale v))) ;;; eof oaklisp-1.3.3.orig/src/world/trace.oak0000664000175000000620000000617007725515165016612 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter ;;; This file defines a native, extremely primitive trace facility. It works ;;; by encapsulating operations and setting the new capsule back into the ;;; variable where the original came from. (define-instance encapsulated-operation type '(the-real-op) (list operation)) (add-method (setter (encapsulated-operation the-real-op) self) (setter the-real-op)) (add-method (locater (encapsulated-operation the-real-op) self) (locater the-real-op)) (add-method (print (encapsulated-operation the-real-op) self stream) (format stream "#" (real-op self))) (add-method (initialize (encapsulated-operation the-real-op) self op) (set! the-real-op op) self) (define-instance real-op locatable-operation) (add-method ((locater real-op) (encapsulated-operation the-real-op) self) (make-locative the-real-op)) (add-method (real-op (encapsulated-operation the-real-op) self) (real-op the-real-op)) (add-method (real-op (operation) self) self) ;;; Some listification targets, to avoid making a lambda every time. (define (in-message args) (let ((op (car args)) (args (cdr args))) (format standard-error "~&Enter ~A with ~A~%" op args) (apply op args))) (define (out-message args) (let ((op (car args)) (args (cdr args))) (let ((ans (apply op args))) (format standard-error "~&Exit ~A with ~A.~%" op ans) ans))) (define (in-out-message args) (let ((op (car args)) (args (cdr args))) (format standard-error "~&Enter ~A with ~A.~%" op args) (let ((ans (apply op args))) (format standard-error "~&Exit ~A with ~A.~%" op ans) ans))) ;;; The encapsulation operators. (define (encapsulate-in op) (add-method ((make encapsulated-operation op) (object) . args) (listify-args in-message op . args))) (define (encapsulate-out op) (add-method ((make encapsulated-operation op) (object) . args) (listify-args out-message op . args))) (define (encapsulate-in-out op) (add-method ((make encapsulated-operation op) (object) . args) (listify-args in-out-message op . args))) ;;; A miniature interface. (define-syntax (trace-variable-in v) `(set! ,v (encapsulate-in (real-op ,v)))) (define-syntax (trace-variable-out v) `(set! ,v (encapsulate-out (real-op ,v)))) (define-syntax (trace-variable-in-out v) `(set! ,v (encapsulate-in-out (real-op ,v)))) (define-syntax (untrace-variable v) `(set! ,v (real-op ,v))) oaklisp-1.3.3.orig/src/world/em.oak0000664000175000000620000000134707725515165016116 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA (%write-char #\M) oaklisp-1.3.3.orig/src/world/Makefile.nm0000664000175000000620000000473110752406630017060 0ustar barakstaff# MS Visual C 6.0 nmake makefile # by Blake McBride # Bigendian machines need bigendian binary oaklisp worlds, so non-cold # worlds are only compatible across machines of the same endianity. all: oakworld.bin # The Oaklisp emulator executable OAK=oaklisp # Flags for the emulator OAKFLAGS=-trace-gc=1 # How to compile oaklisp source files into oaklisp bytecode object files: .SUFFIXES: .oa .oak .oak.oa: $(OAK) $(OAKFLAGS) -- --compile $* --exit !include Makefile-vars ALLOAFILES = $(TOOLFILES) $(MAKEFILES) $(FILESFILES) $(COLDFILES) \ $(MISCFILES) $(COMPFILES) $(RNRSFILES) SOURCE = $(ALLOAFILES:.oa=.oak) Makefile # How to build a new cold world using the world builder tool: new.cold: $(COLDFILES) $(TOOLFILES) -del new.cold -del new.sym $(OAK) $(OAKFLAGS) \ -- \ --load tool \ --eval "(tool-files '($(COLDFILESD:.oa=)) 'new)" \ --exit # How to boot cold world into warm world: oakworld-1.bin: new.cold $(OAK) $(OAKFLAGS) --world new.cold --dump $@ # load successive layers of functionality onto the world MISCFILES2 = $(MISCFILES:.oa=) oakworld-2.bin: oakworld-1.bin $(MISCFILES) $(OAK) $(OAKFLAGS) --world oakworld-1.bin --dump $@ \ -- \ # $(foreach f, $(MISCFILES:.oa=), --load $(f)) \ --load $(MISCFILES2: = --load ) \ --exit COMPFILES2 = $(COMPFILES:.oa=) oakworld-3.bin: oakworld-2.bin $(COMPFILES) $(OAK) $(OAKFLAGS) --world oakworld-2.bin --dump $@ \ -- \ --locale compiler-locale \ # $(foreach f, $(COMPFILES:.oa=), --load $(f)) \ --load $(COMPFILES2: = --load ) \ --locale system-locale --exit RNRSFILES2 = $(RNRSFILES:.oa=) oakworld.bin: oakworld-3.bin $(RNRSFILES) $(OAK) $(OAKFLAGS) --world oakworld-3.bin --dump $@ \ -- \ -eval "(define-instance scheme-locale locale (list system-locale))"\ -locale scheme-locale \ # $(foreach f, $(RNRSFILES:.oa=), --load $(f)) \ --load $(RNRSFILES2: = --load ) \ -locale system-locale --exit # How to rebuild variables included by this Makefile itself: Makefile-vars: $(MAKEFILES) $(FILESFILES) $(OAK) $(OAKFLAGS) \ -- \ --load files --load make-makefile --eval "(make-makefile \"$@\")" \ --exit .PHONY: install install: oakworld.bin copy $** $(DESTDIR)$(prefix)/lib/oaklisp/ .PHONY: clean clean: clean-oa-files -del oakworld-?.bin new.cold new.sym .PHONY: clean-oa-files clean-oa-files: -del $(ALLOAFILES) ## What goes in an official release: .PHONY: release release: $(SOURCE) $(GRAVY) Makefile-vars oakworld.bin copy $** $(RTARGET)/ oaklisp-1.3.3.orig/src/world/crunch.oak0000664000175000000620000002647707725515165017012 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Barak A. Pearlmutter and Kevin J. Lang ;;; A linear graph transformation language implemented with a hairy ;;; macro. Assume two real instructions, no labels. ;;;;;; Features: ;;; ;;; ,x in LHS matches a variable first time; same as ,(identity i) later. ;;; ;;; names for insts in RHS: 1, 2. ;;; ;;; names for classes of insts in FORALL constructs: ;;; ;;; ,(...) in LHS must match computed value. (define (split-crunch stuff) (let* ((i (subsequence? '(=>) stuff)) (lhs (subseq stuff 0 i)) (stuff (tail stuff (+ i 1))) (i (subsequence? '(=>) stuff)) (test (if i (subseq stuff 0 i) '#t)) (rhs (if i (tail stuff (+ i 1)) stuff))) (list lhs (if (pair? test) `(and ,@test) #t) rhs))) (define crunch-class-alist '()) (define-syntax (define-crunch class . stuff) (let ((crunch (split-crunch stuff))) (cond ((assq class crunch-class-alist) => (lambda (it) (push (cdr it) crunch))) (else (push crunch-class-alist (cons class (list crunch))))) 'generic-undefined-value)) ;;; The following macro does all the work. ;;; Helper functions: (define (substitute old new form) (cond ((null? form) form) ((equal? old form) new) ((pair? form) (cons (substitute old new (car form)) (substitute old new (cdr form)))) (else form))) ;;; Take a rhs and substitute in things for numbers. (define (flush-inumbers rhs things) (if (null? rhs) '() (cons (if (number? (car rhs)) (nth things (- (car rhs) 1)) (car rhs)) (flush-inumbers (cdr rhs) things)))) ;;; Take a forall crunch and expand it out. Returns a list of crunches. (define (expand-forall crunch listproc) (destructure (lhs test rhs) crunch (destructure* (('forall v . attributes) . stuff) lhs (let ((instrs (listproc attributes)) (var (varify v))) (map (lambda (instr) (substitute var instr (list (cdr lhs) test rhs))) instrs))))) ;;; Expand out all the FORALLs (define (expand-foralls crunch-list listproc) (iterate aux ((l crunch-list)(a '())) (if (null? l) (reverse a) (let* ((crunch (car l)) (lhs (car crunch))) (if (null? lhs) (aux (cdr l) (cons crunch a)) (let ((lhs0 (car lhs))) (if (and (pair? lhs0) (eq? (car lhs0) 'forall)) (aux (append (expand-forall crunch listproc) (cdr l)) a) (aux (cdr l) (cons crunch a))))))))) ;;; Take x and return ,x. (define (varify x) (list (car ',x) x)) (define (var? x) (and (pair? x) (eq? (car x) (car ',x)))) (define unvarify second) ;;; Take x and return `x. (define (backquotify x) (list (car '`x) x)) ;;; Process a crunch. Returns code which evaluates YESPROC called on ;;; the new list of instructions if it matches and evaluates NOCODE if ;;; it doesn't. INSTRS is a list of the variables that the LHS forms ;;; of CRUNCH are bound to. (define (do-a-crunch crunch instrs yesproc nocode) (destructure (lhs test rhs) crunch (tease-lhs instrs lhs '() nocode test (lambda (bound-vars test nocode) (if-ify test (yesproc (map backquotify (flush-inumbers rhs (map varify instrs)))) nocode))))) ;;; For DEBUGGING: (define (test-a-crunch stuff) (let ((c (split-crunch stuff))) (do-a-crunch c (map genvar/1 (car c)) (lambda (l) (cons 'list l)) `'NOCHANGE))) ;;; For constructing forms. (define (let-ify var val body) (if (and (pair? body) (eq? 'let* (car body))) (destructure* ('let* clauses body) body `(let* ((,var ,val) ,@clauses) ,body)) `(let* ((,var ,val)) ,body))) (define (and-ify new test) (cond ((eq? test '#t) new) ((and (pair? test) (eq? (car test) 'and)) `(and ,new ,@(cdr test))) (else `(and ,new ,test)))) (define (if-ify test yes no) (if (eq? test '#t) yes `(if ,test ,yes ,no))) ;;; Tease apart the LHS while binding variables. ;;; instrs are bound to things that we hope match lhs. (define (tease-lhs instrs lhs bound-vars nocode test yesser) (if (null? instrs) (yesser bound-vars test nocode) (tease-form (car lhs) (car instrs) bound-vars nocode test (lambda (bound-vars test nocode) (tease-lhs (cdr instrs) (cdr lhs) bound-vars nocode test yesser))))) ;;; Tease apart a single LHS clause. (define (tease-form form var bound-vars nocode test yesser) (cond ((null? form) (yesser bound-vars test nocode)) ((symbol? form) `(if (eq? ',form ,var) ,(yesser bound-vars test nocode) ,nocode)) ((is-a? form self-evaluatory-mixin) `(if (eq? ,form ,var) ,(yesser bound-vars test nocode) ,nocode)) ((var? form) (let ((x (unvarify form))) (if (or (not (symbol? x)) (memq x bound-vars)) (yesser bound-vars (and-ify `(eq? ,x ,var) test) nocode) (let-ify x var (yesser (cons x bound-vars) test nocode))))) ;; At this point we know FORM must be a list of things. ((and (var? (car form)) (symbol? (unvarify (car form))) (not (memq (unvarify (car form)) bound-vars))) ;; This clause avoids useless shuffling of variables. ;; It can be removed without loss of correctness (let ((vcar (unvarify (car form)))) (let-ify vcar `(car ,var) (if (null? (cdr form)) (yesser (cons vcar bound-vars) test nocode) (let ((vcdr (genvar))) (let-ify vcdr `(cdr ,var) (tease-form (cdr form) vcdr (cons vcar bound-vars) nocode test yesser))))))) (else ;; Must be a list of things: (let ((vcar (genvar))) (let-ify vcar `(car ,var) (tease-form (car form) vcar bound-vars nocode test (if (null? (cdr form)) yesser (lambda (bound-vars test nocode) (let ((vcdr (genvar))) (let-ify vcdr `(cdr ,var) (tease-form (cdr form) vcdr bound-vars nocode test yesser))))))))))) (define (car-er l x) (if (not (null? l)) (car l) x)) ;; PROC wants current element of L1, next element of L1, and current of L2. (define (hairmap proc l1 l2 default) (if (null? l1) '() (cons (proc (car l1) (car-er (cdr l1) default) (car l2)) (hairmap proc (cdr l1) (cdr l2) default)))) ;; PROC wants current element of L1, code for next element of L1, and ;; current of L2. (define (hairmap1 proc l1 l2 default) (if (null? l1) '() (cons (proc (car l1) (call-er (cdr l1) default) (car l2)) (hairmap1 proc (cdr l1) (cdr l2) default)))) (define (call-er l default) (if (null? l) default `(,(car l)))) (let ((!=lhsl (lambda (n c) (!= n (length (car c)))))) (define (catagorize-crunches cl) (iterate aux ((l cl)(m 0)) (if (null? l) (iterate aux ((i 1)(o '())) (if (> i m) (reverse o) (aux (+ i 1) (cons (del !=lhsl i cl) o)))) (let ((lhsl (length (car (car l))))) (aux (cdr l) (if (> lhsl m) lhsl m))))))) ;;; Really do it. Assume a max of two forms in LHS. (define (hairy-code crunches listproc) (let ((l (catagorize-crunches (expand-foralls crunches listproc))) (yup (lambda (l) `(list ,@l)))) `(list ,@(map (lambda (cl i) (let ((invars (map genvar/1 (iota i))) (vcl (map genvar/1 cl))) `(lambda ,invars (labels ,(reverse (hairmap1 (lambda (this next crunch) `(,this (lambda () ,(do-a-crunch crunch invars yup next)))) vcl cl `'nochange)) ,(call-er vcl `'nochange))))) l (iota (length l)))))) ;;; The termination interface (define-syntax (emit-crunchers class listproc) (let ((it (assq class crunch-class-alist))) (block0 (new-hairy-code (cdr it) (eval listproc #*current-locale)) (set! (cdr it) '())))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; This procedure sorts the productions according to the ; length of their left-hand-sides, and returns a list ; of expression matching functions, each of which only ; handles a given LHS length. (define (new-hairy-code raw-crunch-list listproc) (let ((hacked-crunch-list (catagorize-crunches (expand-foralls raw-crunch-list listproc)))) (cons 'list (map hash-table-hairy-code hacked-crunch-list (iota (length hacked-crunch-list)))))) ; The following procedure generates the code for a single ; pattern matching function which handles all of the productions ; in crunch-list (whose LHS's must be of equal length). ; The generated function uses the first opcode in its ; first argument as a key for retrieving from a hash table ; a sub-function that only tries to apply the productions ; that are relevant for that opcode. ; The sub-functions are generated using a different procedure ; that causes the relevant productions to be tried sequentially. (define (hash-table-hairy-code crunch-list lhs-len) (if (< (length crunch-list) 10) (sequential-hairy-code crunch-list lhs-len) ;fast enough (let* ((sorted-crunch-list (combine-similar-neighbors (sort crunch-list crunch-key-less?) crunch-key-equal?)) (crunch-key-list (map caaaar sorted-crunch-list)) (invars (map genvar/1 (iota lhs-len)))) `(let ((cruncher-lookup-table (make-eq-hash-table))) ,@(map (lambda (crunchers crunch-key) `(set! (table-entry cruncher-lookup-table ',crunch-key) ,(sequential-hairy-code crunchers lhs-len))) sorted-crunch-list crunch-key-list) (lambda ,invars (let ((cruncher (present? cruncher-lookup-table (car ,(car invars))))) (if (not cruncher) 'nochange ((cdr cruncher) ,@invars))))))) ) ; This is Barak's procedure that combines ; a bunch of crunchers into a big labels expression ; that sequentially runs through all of the tests in ; crunch-list with no function calls. (define (sequential-hairy-code crunch-list lhs-len) (let ((invars (map genvar/1 (iota lhs-len))) (crunch-var-names (map genvar/1 crunch-list)) (yup (lambda (l) `(list ,@l)))) `(lambda ,invars (labels ,(reverse (hairmap1 (lambda (this next crunch) `(,this (lambda () ,(do-a-crunch crunch invars yup next)))) crunch-var-names crunch-list `'nochange)) ,(call-er crunch-var-names `'nochange))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (crunch-key-less? a b) (< (#^string (caaar a)) (#^string (caaar b)))) (define (crunch-key-equal? a b) (eq? (caaar a) (caaar b))) ; '(a a b c c c d e) eq? --> '((a a) (b) (c c c) (d) (e)) (define (combine-similar-neighbors inlist similar?) (if (null? inlist) '() (iterate next ((remaining (cdr inlist)) (group-so-far (list (car inlist))) (listout '())) (if (null? remaining) (reverse (cons group-so-far listout)) (let ((this-guy (car remaining))) (if (similar? this-guy (car group-so-far)) (next (cdr remaining) (cons this-guy group-so-far) listout) (next (cdr remaining) (list this-guy) (cons group-so-far listout)))))))) ;;; eof oaklisp-1.3.3.orig/src/world/code-vector.oak0000664000175000000620000001307207725515165017725 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;(initialize %code-vector '(ivar-map) (list variable-length-mixin object)) ;;; Define NTH properly for %CODE-VECTORs. ;;; We conditionalize on whether we're under a big-endian regime at load ;;; time, thus avoiding the check repeatedly at runtime. (cond ((%big-endian?) (add-method (nth (%code-vector) self n) (let* ((n2 (quotient n 2)) (x (%vref self n2))) (if (not (zero? (modulo n 2))) ;; Low 16 bits: (bit-or (ash-left (bit-and (%pointer x) #x3FFF) 2) (%tag x)) ;; High 16 bits: (bit-and #xFFFF (ash-right (%pointer x) 14))))) (add-method ((setter nth) (%code-vector) self n x) (let* ((n2 (quotient n 2)) (x0 (%vref self n2)) (x1 (if (not (zero? (modulo n 2))) ;; Low 16 bits: (%crunch (bit-or (bit-and (%pointer x0) (bit-not #x3FFF)) (ash-right x 2)) (bit-and x #x3)) ;; High 16 bits: (%crunch (bit-or (bit-and (%pointer x0) #x3FFF) (ash-left x 14)) (%tag x0))))) (set! (%vref self n2) x1)))) (else (add-method (nth (%code-vector) self n) (let* ((n2 (quotient n 2)) (x (%vref self n2))) (if (zero? (modulo n 2)) ;; Low 16 bits: (bit-or (ash-left (bit-and (%pointer x) #x3FFF) 2) (%tag x)) ;; High 16 bits: (bit-and #xFFFF (ash-right (%pointer x) 14))))) (add-method ((setter nth) (%code-vector) self n x) (let* ((n2 (quotient n 2)) (x0 (%vref self n2)) (x1 (if (zero? (modulo n 2)) ;; Low 16 bits: (%crunch (bit-or (bit-and (%pointer x0) (bit-not #x3FFF)) (ash-right x 2)) (bit-and x #x3)) ;; High 16 bits: (%crunch (bit-or (bit-and (%pointer x0) #x3FFF) (ash-left x 14)) (%tag x0))))) (set! (%vref self n2) x1))))) (define-instance remap-your-ivars operation) (add-method (remap-your-ivars (%code-vector) self remap-alist real-ivar-map) (let* ((len (length self)) (new-code-vector (make %code-vector len)) (limit (* len 2))) (set! ((%slot 2) new-code-vector) real-ivar-map) (iterate aux ((i 0)) (cond ((< i len) (set! (%vref new-code-vector i) (%vref self i)) (aux (+ i 1))) (else (iterate aux ((i 0)) (cond ((<= limit i) new-code-vector) (else (let ((x (nth new-code-vector i))) (cond ((= x #x600) ;; LOAD-IMM, op=0 and arg=6. (aux (+ i (if (odd? i) 3 4)))) (else (let ((op (bit-and #x3F (ash-right x 2)))) (if (or (= op 12) ;load-bp (= op 13) ;store-bp (= op 17)) ;make-bp-loc (let* ((arg (ash-right x 8)) (xlate (assq arg remap-alist))) (if xlate (set! (nth new-code-vector i) (bit-or (ash-left op 2) (ash-left (cdr xlate) 8))))))) (aux (+ i 1))))))))))))) ;;; Redefine %INSTALL-METHOD-WITH-ENV so it creates new code bodies when ;;; there's an ivar mismatch. (add-method (%install-method-with-env (type operation-method-alist ivar-list) self op code-body env) (let ((code-ivar-map ((%slot 2) code-body))) (iterate aux ((real-ivar-map ivar-list) (check-ivar-map code-ivar-map) (i 0) (remap-alist '())) (cond ((not (null? check-ivar-map)) (let ((x (car check-ivar-map))) (cond ((or (null? x) (eq? x (car real-ivar-map))) (aux (cdr real-ivar-map) (cdr check-ivar-map) (+ 1 i) remap-alist)) (else (let ((p (position-in-list x ivar-list))) (cond ((null? p) (error "Variable ~A declared in ADD-METHOD isn't in ~A, the ivars of ~A." x ivar-list self)) (else (aux (cdr real-ivar-map) (cdr check-ivar-map) (+ i 1) (cons (cons i p) remap-alist))))))))) (else (let ((the-method (%allocate %method 3)) (the-code-body (if (null? remap-alist) code-body (remap-your-ivars code-body remap-alist ivar-list)))) (set! ((%slot 1) the-method) the-code-body) (set! ((%slot 2) the-method) env) (cond ((and (eq? self object) ((%slot 1) op)) (set! ((%slot 1) op) the-method)) (else (when (and ((%slot 1) op) (not (eq? ((%slot 1) op) 0))) ;; Toss it on to OBJECT's OPERATION-METHOD-ALIST: (set! ((%slot 7) object) (cons (cons op ((%slot 1) op)) ((%slot 7) object)))) ;; Flush the method cache (set! ((%slot 2) op) 0) ;; install the newly created method (let ((the-ass (%assq op operation-method-alist))) (set! ((%slot 1) op) nil) (if the-ass (set! (cdr the-ass) the-method) (set! operation-method-alist (cons (cons op the-method) operation-method-alist)))))) op)))))) (define-constant %make-lambda-with-env (add-method ((make-open-coded-operation '((make-lambda)) 2 1) (%code-vector) some-code an-environment) (%make-lambda-with-env some-code an-environment))) ;;; eof oaklisp-1.3.3.orig/src/world/do.oak0000664000175000000620000000134707725515165016117 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA (%write-char #\.) oaklisp-1.3.3.orig/src/world/symbols.oak0000664000175000000620000001501407725515165017201 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;;; This file defines the Symbol datatype. ;(initialize symbol '(print-name) (list object)) (add-method (initialize (symbol print-name) self the-print-name) (set! print-name the-print-name) self) (define symbol-table (make-string-hash-table)) (define-instance intern settable-operation) (add-method (intern (string) self) (cond ((present? symbol-table self) => cdr) (else (set! (present? symbol-table self) (make symbol self))))) (add-method (intern (symbol print-name) self) (if (present? symbol-table print-name) (warning "attempt to reintern symbol ~S ignored.~%" self) (set! (present? symbol-table print-name) self))) ;;; The following variable is used so that the symbols.oa file does ;;; not have to be manually edited each time symbols is recompiled. (set! #*symbol-slashification-style #f) (add-method (print (symbol print-name) self stream) (cond ((and #*print-escape (requires-slashification? self)) (cond ((eq? #*symbol-slashification-style 't-compatible) (cond ((eq? self '||) (write-string "#[symbol \"\"]" stream)) (else (dotimes (i (length print-name)) (write-char stream #\\) (write-char stream (nth print-name i)))))) (else (write-char stream #\|) (write-string-with-slashes print-name #\| stream) (write-char stream #\|)))) (else (write-string print-name stream)))) (add-method (#^string (symbol print-name) self) print-name) (add-method (#^symbol (string) self) (intern self)) (add-method (#^symbol (sequence) self) (intern (#^string self))) (let ((counter 0)) (define (gensym x) (block0 (#^symbol (format #f "~A~D" x counter)) (set! counter (+ counter 1))))) (define generate-symbol gensym) (define (genvar) (gensym "v")) (define (genvar/1 ignored) (genvar)) ;(add-method (append (symbol) a b) ; (#^symbol (append (#^string a) (#^string b)))) (add-method (append (symbol) arg . rest) (format #t "warning: we are phasing out append for symbols (e.g. ~a)~%" arg) (listify-args (lambda (args) (#^symbol (apply append (cons (#^string arg) (map #^string args) )))) . rest)) ;;; Things that can make a symbol require slashification: ;;; A lower case character. ;;; First character not a constituent. ;;; Any chararacter other than the first neither a contituent nor a ;;; non-terminating macro character. ;;; Being || or |.| or |...|. ;;; Looking like a number: either an integer, or a fraction, or an ;;; integer with an embedded decimal point. ;;; ;;; Only the last condition is hairy. We use a DFA, with states: ;;; --n1-- --n2-- --n3-- --n4-- ;;; ['-'] * ['/' *] ;;; ['-'] * ['.' *] ;;; ['-'] '.' * ;;; The initial '-' doesn't get a state because it's handled (along with ;;; initial non-terminating macro chars) by some prologue code. (add-method (requires-slashification? (symbol print-name) self) ;; It is somewhat unfortunate that || |.| and |...| get interned because ;; they are mentioned below. In fact, in the initial world, these are the ;; only symbols requiring slashification. (or (eq? self '||) (eq? self '|.|) (eq? self '|...|) (let ((l (length print-name)) (base #*print-radix)) (labels ( ((n1 i) ;; Before first char of first block of digits (if (= i l) #f (let* ((c (nth print-name i)) (c-syntax (nth standard-read-table c))) (n1.5 i c c-syntax)))) ((n1.5 i c c-syntax) ;; Before first char of first block of digits (half done) (if (and (or (eq? c-syntax 'constituent) (and (pair? c-syntax) (eq? (car c-syntax) 'nonterminating-macro))) (digit? c base)) (n2 (+ 1 i)) (cond ((eq? c #\.) (n3 (+ 1 i))) (else (scan.5 i c c-syntax))))) ((n2 i) ;; After first char of first block of digits (if (= i l) #t (let* ((c (nth print-name i)) (c-syntax (nth standard-read-table c))) (if (and (or (eq? c-syntax 'constituent) (and (pair? c-syntax) (eq? (car c-syntax) 'nonterminating-macro))) (digit? c base)) (n2 (+ 1 i)) (cond ((eq? c #\/) (n3 (+ 1 i))) ((eq? c #\.) (n4 (+ 1 i))) (else (scan.5 i c c-syntax))))))) ((n3 i) ;; Before required digit of the last block of digits (if (= i l) #f (let* ((c (nth print-name i)) (c-syntax (nth standard-read-table c))) (if (and (or (eq? c-syntax 'constituent) (and (pair? c-syntax) (eq? (car c-syntax) 'nonterminating-macro))) (digit? c base)) (n4 (+ 1 i)) (scan.5 i c c-syntax))))) ((n4 i) ;; Before optional digit of the last block of digits (if (= i l) #t (let* ((c (nth print-name i)) (c-syntax (nth standard-read-table c))) (if (and (or (eq? c-syntax 'constituent) (and (pair? c-syntax) (eq? (car c-syntax) 'nonterminating-macro))) (digit? c base)) (n4 (+ 1 i)) (scan.5 i c c-syntax))))) ((scan i) ;; Scan along for a character that requires slashification (if (= i l) #f (let* ((c (nth print-name i)) (c-syntax (nth standard-read-table c))) (scan.5 i c c-syntax)))) ((scan.5 i c c-syntax) (if (and (or (eq? c-syntax 'constituent) (and (pair? c-syntax) (eq? (car c-syntax) 'nonterminating-macro))) ;; Got to be constituent and not lowercase char too. (let ((cn (#^number c))) (or (< cn (#^number #\a)) (< (#^number #\z) cn)))) (scan (+ 1 i)) #t)) ) (let* ((c (nth print-name 0)) (c-syntax (nth standard-read-table c))) (or (not (eq? c-syntax 'constituent)) (if (eq? c #\-) (n1 1) (n1.5 0 c c-syntax)))))))) ;;; eof oaklisp-1.3.3.orig/src/world/expand.oak0000664000175000000620000000757107725515165017001 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang and Barak A. Pearlmutter ;;; The quick and dirty macro expander written in T ported back to Oaklisp. (define-instance expand-groveling operation) (define-instance idiosyncratically-grovel operation) (define (improper-list? x) (if (pair? x) (cdr (last-pair x)) x)) (define (make-proper x) (if (pair? x) (let ((the-copy (copy x))) (set! (cdr (last-pair the-copy)) nil) the-copy) '())) (define (safe-length self) (if (pair? self) (+ 1 (safe-length (cdr self))) 0)) (define (map-proper-part op l) (let ((improper-part (improper-list? l))) (if improper-part (let ((proper-answer (map op (make-proper l)))) (set! (cdr (last-pair proper-answer)) improper-part) proper-answer) (map op l)))) (define (special-form? sym) (or (eq? sym 'quote) (eq? sym '%block) (eq? sym '%if) (eq? sym '%add-method) (eq? sym '_%add-method) (eq? sym '%make-locative) (eq? sym '%labels))) ; eventually (%unwind-protect unwind-protect0 catch %fluid-bind) (define trace-expansion nil) (add-method (expand-groveling (locale) self form) (if trace-expansion (format #t "~&expand-groveling ~S~%" form)) (cond ((is-a? form self-evaluatory-mixin) form) ((not (pair? form)) (if (special-form? form) (warning "Special form specifier ~A used as a variable.~%" form)) form) ((special-form? (car form)) (idiosyncratically-grovel self form)) (else (let ((m (macro? self (car form)))) (cond (m (expand-groveling self (m form))) (else (map-proper-part (lambda (x) (expand-groveling self x)) form))))))) (add-method (idiosyncratically-grovel (locale) self form) (if trace-expansion (format #t "~&idiosyncratically-grovel ~s~%" form)) (let ((s (car form))) (cond ((or (eq? s '%if) (eq? s '%block) (eq? s '%make-locative)) `(,(first form) . ,(map (lambda (x) (expand-groveling self x)) (cdr form)))) ((or (eq? s '%add-method) (eq? s '_%add-method)) (destructure* (kind (op (typ . ivars) . args) body) form `(,kind (,(expand-groveling self op) (,(expand-groveling self typ) . ,ivars) . ,args) ,(expand-groveling self body)))) ((eq? s '%labels) `(,(first form) ,(map (lambda (x) (destructure (var val) x `(,var ,(expand-groveling self val)))) (second form)) ,(expand-groveling self (third form)))) ((eq? s 'quote) form) (else (error "Form ~S can't be idiosyncratically groveled." form))))) ; for later use in idiosyncratically-grovel ;((memq s '(catch %fluid-bind)) ; `(,(first form) ,(second form) ; . ,(map (lambda (x) (expand-groveling self x)) ; (cddr form)))) ;this is a more correct version of expand-groveling ;(define (expand-groveling self form) ; (cond ((symbol? form) form) ; ((is-a? form self-evaluatory-mixin) ; form) ; ((special-form? (car form)) ; (idiosyncratically-grovel self form)) ; ((macro? self (car form)) ; (expand-groveling self ((macro? self (car form)) form))) ; (t (map-proper-part (lambda (x) (expand-groveling self x)) form)))) ; ;;; note 11 was (else `(add-method ((',make ',operation) . ,(cadr form)) . ,(cddr form))))))) oaklisp-1.3.3.orig/src/world/kernel.oak0000664000175000000620000000576607725515165017006 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;;; This comes after kernel0 and kernel1, so ADD-METHOD should work now. ;;; It is time to set up some standard bindings. ;;; T and NIL are defined by the world builder ;; This early definition of EQ? is necessary for mapping, but EQ? is redefined ;; properly later. (define (eq? x y) (eq? x y)) (define-instance coercable-type type '(co-op) (list type)) (add-method (initialize (coercable-type co-op) self the-ivar-list the-supertype-list) (^super type initialize self the-ivar-list the-supertype-list) (set! co-op (add-method ((make operation) (self) self) self)) self) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Define some primitive types. ;; ;; This mixin is for the compiler's benefit: (define-instance self-evaluatory-mixin type '() '()) ;;; The cons heirarchy is: ;;; ;;; sequence ;;; \ ;;; list-type ;;; / \ ;;; pair null-type (only instance is "()") ;;; / ;;; cons-pair (define-instance sequence type '() '()) (define-instance list-supertype type '() (list coercable-type)) (define-instance list-type list-supertype '() (list sequence)) (add-method (make (list-supertype) self len initial-element) (iterate aux ((l '()) (i len)) (if (zero? i) l (aux (cons initial-element l) (- i 1))))) (define-instance pair type '() (list list-type)) (initialize null-type '() (list self-evaluatory-mixin list-type object)) (initialize cons-pair '(the-car the-cdr) (list pair object)) (%your-top-wired cons-pair) (add-method (initialize (cons-pair the-car the-cdr) self new-car new-cdr) (set! the-car new-car) (set! the-cdr new-cdr) self) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Yet more types (initialize locative '() (list object)) (set! ((%slot 0) string) coercable-type) (initialize string '() (list self-evaluatory-mixin object)) ;;;;;;;; (define-instance symbol coercable-type '(print-name) (list object)) ;;;;;;;;;; ;; This was moved here from promise.oak so system code can add methods to it. (define-instance forcible type '() '()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (is-a? obj typ) ;Determine whether OBJ is-a TYP (subtype? (get-type obj) typ)) ;;;; eof oaklisp-1.3.3.orig/src/world/fastmap.oak0000664000175000000620000001065007725515165017145 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter (add-method (map1 (operation) op oldcopy) (and oldcopy (let ((newcopy (cons (op (car oldcopy)) nil))) (iterate next ((oldpair (cdr oldcopy))(last-newpair newcopy)) (if oldpair (next (cdr oldpair) (set! (cdr last-newpair) (cons (op (car oldpair)) nil))) newcopy))))) (add-method (map2 (operation) op l1 l2) (and (not (null? l1)) (not (null? l2)) (let ((newcopy (cons (op (car l1)(car l2)) '()))) (iterate next ((oldpair1 (cdr l1)) (oldpair2 (cdr l2)) (last-newpair newcopy)) (if (and (not (null? oldpair1)) (not (null? oldpair2))) (next (cdr oldpair1) (cdr oldpair2) (set! (cdr last-newpair) (cons (op (car oldpair1)(car oldpair2)) '()))) newcopy))))) ; 3.1 sec for 10000 (now 2.2) (add-method (map! (operation) op lis) (iterate next ((l lis)) (cond (l (set! (car l) (op (car l))) (next (cdr l))) (else lis)))) ; 2.8 sec for 10000 (add-method (for-each1 (operation) op l) (iterate next ((l l)) (when l (op (car l)) (next (cdr l))))) ; 3.1 sec for 10000 (add-method (mem (operation) pred ob l) (iterate next ((l l)) (cond ((null? l) '()) ((pred ob (car l)) l) (else (next (cdr l)))))) ; 1.4 sec for 10000 (define (memq ob l) (iterate next ((l l)) (cond ((null? l) '()) ((eq? ob (car l)) l) (else (next (cdr l)))))) ; 3.2 sec for 10000 (add-method (ass (operation) pred ob l) (iterate next ((l l)) (cond ((null? l) '()) ((pred ob (caar l)) (car l)) (else (next (cdr l)))))) ; 1.5 sec for 10000 (define (assq ob l) (iterate next ((l l)) (cond ((null? l) '()) ((eq? ob (caar l)) (car l)) (else (next (cdr l)))))) ;%assq takes 0.06 sec for 10000 ; 2 sec for 10000 (was 8 before method cache) (with-operations (last-pair-next) (add-method (last-pair-next (pair) self prev-cdr) (last-pair-next (cdr self) self)) (add-method (last-pair-next (object) self prev-cdr) prev-cdr) (add-method (last-pair-next (forcible) self prev-cdr) (last-pair-next (force self) prev-cdr)) (add-method (last-pair (pair) self) (last-pair-next (cdr self) self))) #| ; 5 sec for 10000 (was 20) (add-method (last-pair-a (pair) self) (iterate last-pair ((self self)) (if (is-a? (cdr self) pair) (last-pair (cdr self)) self))) ; 4 sec for 10000 (with-operations (lpoc-next) (add-method (lpoc-next (pair) oldpair last-newpair) (let ((newpair (cons (car oldpair) nil))) (set! (cdr last-newpair) newpair) (lpoc-next (cdr oldpair) newpair))) (add-method (lpoc-next (object) oldobj last-newpair) (set! (cdr last-newpair) oldobj) last-newpair) (add-method (last-pair-of-copy (pair) oldpair) (let ((newpair (cons (car oldpair) nil))) (lpoc-next (cdr oldpair) newpair)))) |# #| ; now the correct definition lives back in mapping.oak (add-method (append (pair) oldcopy b) (let ((newcopy (cons (car oldcopy) b))) (iterate next ((oldpair (cdr oldcopy))(last-newpair newcopy)) (if oldpair (next (cdr oldpair) (set! (cdr last-newpair) (cons (car oldpair) b))) newcopy)))) |# #| (CODE () ( (CHECK-NARGS 2) (LOAD-STK 1 B) (LOAD-STK 1 OLDCOPY) (CAR) (CONS) (LOAD-STK 0 NEWCOPY) (LOAD-STK 2 OLDCOPY) (CDR) LABEL0 (LOAD-STK 0 OLDPAIR) (BRANCH-NIL ELSE1) (LOAD-STK 4 B) (LOAD-STK 1 OLDPAIR) (CAR) (CONS) (LOAD-STK 2 LAST-NEWPAIR) (SET-CDR) (BLAST 2) (CDR) (BRANCH LABEL0) ELSE1 (POP 2) (BLT-STK 1 2) (RETURN) )) |# ;reverse takes 2.1 sec ;reverse! takes 2.2 sec oaklisp-1.3.3.orig/src/world/compile-bench.oak0000664000175000000620000001024007725515165020212 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Barak A. Pearlmutter & Kevin J. Lang ;;; Define the stuff to link in fasl format code segments, and to load files. (define-instance %ivar-map locatable-operation) (add-method ((locater %ivar-map) (%code-vector ivar-map) self) (make-locative ivar-map)) (define (link-code-segment locale segment) (iterate aux0 ((inputs segment) (outputs '()) (code-resolution-lists '())) (cond ((null? inputs) (let ((outputs (reverse outputs))) (dolist (crl (reverse code-resolution-lists)) (dolist (clause crl) (set! (contents (cdr clause)) (nth outputs (car clause))))) (car outputs))) (else (let* ((input (car inputs)) (resolution-list (first input)) (code (cddr (second input)));the cddr strips off the zeros where the ivar list belongs. (instruction-count (length code)) (word-count (quotient (+ instruction-count 1) 2)) (v (make %code-vector word-count))) (iterate aux ((c code) (i 0)) (cond (c (set! (nth v i) (car c)) (aux (cdr c) (+ i 1))) (else (iterate aux ((resolution-list resolution-list) (code-number-to-locs-alist '())) (cond ((null? resolution-list) (aux0 (cdr inputs) (cons v outputs) (cons code-number-to-locs-alist code-resolution-lists))) (else (let ((clause (car resolution-list))) (destructure (which where what) clause (cond ((eq? where 0) (cond ((not (or (eq? which 'constant) (eq? which 2))) (error "Bad resolution clause ~S; only constants can be put in the IVAR-MAP slot." clause)) (else (set! (%ivar-map v) what) (aux (cdr resolution-list) code-number-to-locs-alist)))) (else (let ((where-loc (make-locative (%vref v (- (quotient where 2) 1))))) (cond ((or (eq? which 'constant)(eq? which 2)) (set! (contents where-loc) what) (aux (cdr resolution-list) code-number-to-locs-alist)) ((or (eq? which 'variable)(eq? which 0)) (set! (contents where-loc) (or (variable? locale what) (let* ((x variable-undefined-value) (y (make-locative x))) (format #t "Warning: installing ~S in ~A.~%" what locale) (set! (variable? locale what) y) y))) (aux (cdr resolution-list) code-number-to-locs-alist)) ((or (eq? which 'code)(eq? which 1)) (aux (cdr resolution-list) (cons (cons what where-loc) code-number-to-locs-alist))) (else (error "Weird resolution clause ~S." clause))))))))))))))))))) (define (load-code-segment locale segment) ((%install-method-with-env object (make operation) (link-code-segment locale segment) %empty-environment) 'loaded)) (define (load-oa-file locale file) (load-code-segment locale (with-open-file (s (append (#^string file) ".oa") in) (let ((red (read s))) (if (pair? (caar red)) red (make-oa-list red)))))) #| (define (load-oa-file locale file) (load-code-segment locale (let ((s (open-input-file (append (#^string file) ".oa")))) (block0 (read s) (close s))))) |# (define (load-oak-file locale file) (dofile (append file ".oak") (lambda (expr) (format #t "~A...~%" expr) (dumb-eval (expand-groveling locale expr) '() locale)))) (define (load-omac-file locale file) (dofile (append file ".omac") (lambda (expr) (dumb-eval expr '() locale)))) ;;; eof oaklisp-1.3.3.orig/src/world/scheme.oak0000664000175000000620000001106207725515165016754 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang ;;; This is a compatibility package for R3RS Scheme. ;;; This file defines things that are part of R3RS but that are not ;;; part of standard Oaklisp, usually because they are non-generic ;;; versions of operations which have generic variants in Oaklisp, but ;;; sometimes because we just decided to be gratuitously incompatible. ;(define (boolean? x) #f) ;(add-method (boolean? (truths) x) #t) ; ;(define (boolean? x) (is-a? x truths)) ; ;(define (boolean? x) (or (eq? #f x) (eq? #t x))) ; ;(define (boolean? x) (if (not x) #t (eq? x #t))) ; (define (boolean? x) (eq? x (not (not x)))) (define-constant set-car! (setter car)) (define-constant set-cdr! (setter cdr)) (define list-tail tail) (define list-ref nth) (define symbol->string #^string) (define string->symbol #^symbol) (define-constant char=? =) (define-constant char? >) (define-constant char<=? <=) (define-constant char>=? >=) (define char-ci=? (lambda (c1 c2) (= (upcase c1) (upcase c2)))) (define char-ci? (lambda (c1 c2) (> (upcase c1) (upcase c2)))) (define char-ci<=? (lambda (c1 c2) (<= (upcase c1) (upcase c2)))) (define char-ci>=? (lambda (c1 c2) (>= (upcase c1) (upcase c2)))) (define (char-whitespace? c) (eq? 'whitespace (nth standard-read-table c))) (define char->integer #^number) (define integer->char #^character) (define char-upcase upcase) (define char-downcase downcase) (define string-length length) (define string-ref nth) (define string-set! (setter nth)) (define-constant string=? =) (define-constant string? >) (define-constant string<=? <=) (define-constant string>=? >=) (define string-ci=? (lambda (c1 c2) (= (upcase c1) (upcase c2)))) (define string-ci? (lambda (c1 c2) (> (upcase c1) (upcase c2)))) (define string-ci<=? (lambda (c1 c2) (<= (upcase c1) (upcase c2)))) (define string-ci>=? (lambda (c1 c2) (>= (upcase c1) (upcase c2)))) (define substring subseq-indexes) ; (define string-append append) (define (string-append . args) (if (zero? (rest-length args)) "" (append . args))) (define string->list #^list-type) (define list->string #^string) (define string-copy copy) (define string-fill! fill!) (define (make-vector n) (make simple-vector n)) (define vector-length length) (define vector-ref nth) (define vector-set! (setter nth)) (define vector->list #^list-type) (define list->vector #^simple-vector) (define vector-fill! fill!) (define input-port? (type-pred input-stream)) (define output-port? (type-pred output-stream)) (define (call-with-input-file string proc) (with-open-file (s string in) (proc s))) (define (call-with-output-file string proc) (with-open-file (s string out) (proc s))) (define (current-input-port) standard-input) (define (current-output-port) standard-output) (define (eof-object? x) (eq? x the-eof-token)) (define close-input-port close) (define close-output-port close) (define write (let ((write0 (lambda (obj port) (bind ((#*print-escape #t)) (print obj port))))) (lambda (obj . rest) (if (zero? (rest-length rest)) (write0 obj standard-output . rest) (write0 obj . rest))))) (define display (let ((display0 (lambda (obj port) (bind ((#*print-escape #f)) (print obj port))))) (lambda (obj . rest) (if (zero? (rest-length rest)) (display0 obj standard-output . rest) (display0 obj . rest))))) ;;; Argument order incompatibility hackaround: (add-method (write-char (character) char stream) (write-char stream char)) ;;; with no args: (add-method (newline (object)) (newline standard-output)) (define (write-line x) (print x standard-output)) #| (add-method (read (object)) (read standard-input)) |# ;;; eof oaklisp-1.3.3.orig/src/world/unwind-protect.oak0000664000175000000620000001031607725515165020473 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter ;;; The global %WINDINGS holds a list of items of the form ;;; (UNWIND-LANBDA WIND-LAMBDA . FLUID-BINDING-LIST), and the global ;;; %WIND-COUNT holds the length of %WINDINGS. Continuations store ;;; the values of these two variables for use when they're continued, ;;; and catch tags hold just the value of %WIND-COUNT which suffices. ;;; When continuing a continuation, the caller unwinds to the join ;;; point and then the callee winds back up to the destination point. ;;; Set up the necessary globals used for holding the winding stack. (define (unset-windings) (set! %windings '()) (set! %wind-count 0)) (unset-windings) (add-warm-boot-action unset-windings) ;;; This routine returns the height of the join point. (define (find-join-point windings0 count0 windings1 count1) (labels ((aux (lambda (windings0 windings1 count) (cond ((eq? windings0 windings1) count) (else (aux (cdr windings0) (cdr windings1) (- count 1))))))) (cond ((= count0 count1) (aux windings0 windings1 count0)) ((< count0 count1) (aux windings0 (tail windings1 (- count1 count0)) count0)) (else (aux (tail windings0 (- count0 count1)) windings1 count1))))) ;;; Usage: (rewind join-point new-%windings new-%wind-count) (labels ((rewind-aux (lambda (from-count to to-count) (unless (= from-count to-count) (rewind-aux from-count (cdr to) (- to-count 1)) (set! %windings to) (set! %wind-count to-count) (let ((item (car to))) ; (set! fluid-binding-list (cddr item)) (set-current-fluid-bindings (cddr item)) ((cadr item))))))) (define (rewind from-count to to-count) (unless (= from-count to-count) (rewind-aux from-count to to-count) (set! %windings to) (set! %wind-count to-count)))) ;;; Usage as above. (define (unwind from from-count to-count) (iterate aux ((w from)(c from-count)) (set! %windings w) (set! %wind-count c) (unless (= c to-count) (let ((item (car w))) ; (set! fluid-binding-list (cddr item)) (set-current-fluid-bindings (cddr item)) ((car item))) (aux (cdr w)(- c 1))))) ;;; The standard interface to this facility: (define (dynamic-wind before during after) (before) (push %windings (list* after before (get-current-fluid-bindings))) (set! %wind-count (+ %wind-count 1)) (block0 (during) (pop %windings) (set! %wind-count (- %wind-count 1)) (after))) ;;; And now some fancy interfaces: ;;; This one keeps you from having to do lambda wrapping: (define-syntax (wind-protect before during after) ;; `(dynamic-wind (lambda () ,before) (lambda () ,during) (lambda () ,after)) (let ((a (genvar))(b (genvar))) `(let ((,b (lambda () ,before)) (,a (lambda () ,after))) (,b) (push %windings (list* ,a ,b (get-current-fluid-bindings))) (set! %wind-count (+ %wind-count 1)) (block0 ,during (pop %windings) (set! %wind-count (- %wind-count 1)) (,a))))) ;;; This one does different things depending on whether the entries ;;; and exists are normal or abnormal. (define-syntax (funny-wind-protect normal-before abnormal-before during normal-after abnormal-after) `(block ,normal-before (push %windings (list* (lambda () ,abnormal-after) (lambda () ,abnormal-before) (get-current-fluid-bindings))) (set! %wind-count (+ %wind-count 1)) (block0 ,during (pop %windings) (set! %wind-count (- %wind-count 1)) ,normal-after))) ;;; eof oaklisp-1.3.3.orig/src/world/destructure.oak0000664000175000000620000001102207725515165020055 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter (define (destructure-2 pattern expr body expr-important noper) (cond ((symbol? pattern) `(let ((,pattern ,expr)) ,body)) ((and (not noper) (or (eq? '#f pattern) (eq? '#t pattern) (eq? 'quote (car pattern)))) (if expr-important `(block ,expr ,body) body)) ((eq? '#t pattern) (if expr-important `(block ,expr ,body) body)) ((eq? '#f pattern) (let ((v (genvar))) `(let ((,v ,expr)) (if (null? ,v) ,body ,(noper v '#f))))) ((eq? 'quote (car pattern)) (let ((v (genvar))) `(let ((,v ,expr)) (if (eq? ,v ',(second pattern)) ,body ,(noper v (second pattern)))))) (else (let* ((v (genvar)) (inner (destructure-2 (car pattern) `(car ,v) (destructure-2 (cdr pattern) `(cdr ,v) body #f noper) #f noper))) (if noper `(let ((,v ,expr)) (if (pair? ,v) ,inner ,(noper v pattern))) `(let ((,v ,expr)) ,inner)))))) ;;; This is for destructuring lists. As in ;;; (destructure (a (b c) (d . e) f) my-list ;;; (crunch-on a c b d f e)) ;;; Sort of the inverse of backquote. ;;; In the pattern, #t's are placed in positions to be ignored. In order to ;;; be compatible with destructure*, #f's and (QUOTE x)'s are also ignored. (define-syntax destructure (lambda (form) (destructure (#t pattern expr . body) form (destructure-2 pattern expr `(block ,@body) #t #f)))) ;;; DESTRUCTURE* is just like DESTRUCTURE, except that positions with ;;; #F's and ()'s are required to be #F's and ()'s, and positions with ;;; 'FOO, alias (QUOTE FOO), are required to have the literal value ;;; FOO in them, where FOO is not evaluated. Positions with #T's have ;;; the corresponding value ignored; use '#T to check for a literal #T. ;;; Destructure* is primarily useful in macro expanders, where it can ;;; be used to do much of the syntax checking. #|| (define (contains-#t x) (or (eq? x '#t) (and (pair? x) (or (contains-#t (car x)) (contains-#t (cdr x)))))) ||# (define (destr-signaler-lambda found desired) ;;(if (contains-#t desired) ;; `(signal-destructure-error ,found "a list") `(signal-destructure-error ,found ',desired) ;) ) (define-syntax destructure* (lambda (form) (destructure (#t pattern expr . body) form (destructure-2 pattern expr `(block . ,body) #t destr-signaler-lambda)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This is even hairier. It is like DESTRUCTURE* except that instead ;;; of an error in the event of a match failure, there are multiple ;;; templates, and each template gets a chance to match. Syntax is ;;; ;;; (destructure** expr ;;; (template1 . body1) ;;; (template2 . body2) ;;; ... ;;; [(OTHERWISE . nomatch-body)] ) ;;; ;;; If no OTHERWISE clause is passed, an appropriate error is signaled. (define-syntax (destructure** expr . clauses) (let* ((v (genvar)) (tags (map genvar/1 clauses)) (tags0 (append (cdr tags) '(#f)))) (if (null? clauses) `(error "No DESTRUCTURE** clauses, so none match ~S." ,expr) `(let ((,v ,expr)) (labels ,(map (lambda (this next clause) (destructure* (pattern . body) clause `(,this (lambda () ,(if (eq? pattern 'otherwise) (if next (error "Nonterminal clause ~S in DESTRUCTURE**." clause) `(block . ,body)) (destructure-2 pattern v `(block . ,body) #f (if next (lambda (a b) `(,next)) destr-signaler-lambda))))))) tags tags0 clauses) (,(car tags))))))) ;;; (define (signal-destructure-error found required) ;;(cerror "Proceed destructuring anyway." ;; "While destructuring, ~S was found where ~S is required." ;; found required) (error "While destructuring, ~S was found where ~A is required." found required)) ;;; eof oaklisp-1.3.3.orig/src/world/read-char.oak0000664000175000000620000001272007725515165017340 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang ;;; Thanks to Richard O'Keefe for a few modifications ;;; Syntax: '#\' or '#\' ({'s' 'c' 'm' 'shift' 'control' 'meta'}'-')+ ;;; Where (define-hash-macro-char #\\ (lambda (stream char arg) (when arg (cerror "Ignore the font specifier." "A #~A~C was encountered, but #~C does not understand fonts yet." arg char char)) (unread-char stream char) (let* ((token (read stream)) (str (#^string token)) (len (length str))) (cond ((= len 1) (nth str 0)) (else (let ((token (upcase-first-char token))) (cond ((#^character token) => identity) (else (cerror "Supply a character to be returned instead." "The token ~S cannot be interpreted as a character." str))))))))) (define (upcase-first-char sym) (let* ((str (#^string sym)) (char (nth str 0)) (nchar (upcase char))) (cond ((eq? char nchar) sym) (else (let* ((len (length str)) (str2 (make-string len))) (dotimes (i len) (set! (nth str2 i) (nth str i))) (set! (nth str2 0) nchar) (#^symbol str2)))))) (let ((named-character-table '())) (add-method (#^character (symbol) sym) (cond ((assq sym named-character-table) => cdr) (else nil))) (add-method ((setter #^character) (symbol) sym char) (let ((char (#^character char))) (cond ((assq sym named-character-table) => (lambda (x) (set! (cdr x) char))) (else (push named-character-table (cons sym char)) char)))) (add-method (#^symbol (character) char) (cond ((rassq char named-character-table) => car) (else #f)))) ;;; Note: The ASCII name for the character with all bits off is ;;; NUL. Not NULL, N-U-L, three letters. The correct name has ;;; been added. "null" is still there so old code won't break. ;;; The ASCII name DEL for #o177 has also been added. In order ;;; to help port code from other Schemes, the following names have ;;; been added: ;;; altmode = #\esc ;;; escape = #\esc ;;; rubout = #\del ;;; They are not "standard" names (indeed, the only standard names ;;; are #\Space and #\Newline). They are placed in the table early ;;; so that the ASCII names will be generated in output. (set! (#^character 'null) 0) ; Idiosyncratic name (set! (#^character 'nul) 0) ; ASCII name. (set! (#^character 'soh) 1) (set! (#^character 'stx) 2) (set! (#^character 'etx) 3) (set! (#^character 'eot) 4) (set! (#^character 'enq) 5) (set! (#^character 'ack) 6) (set! (#^character 'bel) 7) (set! (#^character 'bs) 8) (set! (#^character 'ht) 9) (set! (#^character 'nl) 10) ; Weird name (set! (#^character 'lf) 10) ; ASCII name (set! (#^character 'vt) 11) (set! (#^character 'np) 12) ; Weird name (set! (#^character 'ff) 12) ; ASCII name (set! (#^character 'cr) 13) (set! (#^character 'so) 14) (set! (#^character 'si) 15) (set! (#^character 'dle) 16) (set! (#^character 'dc1) 17) (set! (#^character 'dc2) 18) (set! (#^character 'dc3) 19) (set! (#^character 'dc4) 20) (set! (#^character 'nak) 21) ;; Previously removed so #\^V would print as #\^V so T could read it. ;; No longer necessary, since the world builder is running in Oaklisp not T. (set! (#^character 'syn) 22) (set! (#^character 'etb) 23) (set! (#^character 'can) 24) ;; As above, used to be commented out so #\^Y would be generated for T. (set! (#^character 'em) 25) (set! (#^character 'sub) 26) (set! (#^character 'altmode) 27) ; A common name (set! (#^character 'escape) 27) ; A common name (set! (#^character 'esc) 27) ; ASCII name (set! (#^character 'fs) 28) (set! (#^character 'gs) 29) (set! (#^character 'rs) 30) (set! (#^character 'us) 31) (set! (#^character 'delete) 127) ; A common name (set! (#^character 'rubout) 127) ; A common name (set! (#^character 'del) 127) ; ASCII name ;;; These go at the end so that these characters will get printed this way. (set! (#^character 'return) 13) (set! (#^character 'newline) 10) (set! (#^character 'form) 12) (set! (#^character 'page) 12) (set! (#^character 'tab) 9) (set! (#^character 'space) 32) (set! (#^character 'backspace) 8) (set! (#^character 'bell) 7) (set! (#^character 'fluid) 22) (set! (#^character 'coercer) 25) #| (define (read-fancy-char stream) (labels (((after-quote r-charlist) (normal (cons (read-char stream) r-charlist))) ((normal r-charlist) (let* ((char (read-char stream)) (syntax (nth standard-read-table char))) (cond ((or (eq? syntax 'constituent) (and (not (symbol? syntax)) (eq? (car syntax) 'nonterminating-macro))) (normal (cons char r-charlist))) ((eq? syntax 'single-escape) (after-quote r-charlist)) (else (unread-char stream char) (parse-token (reverse! r-charlist)))))) ((parse-token charlist) ( |# oaklisp-1.3.3.orig/src/world/tool.oak0000664000175000000620000005370307725515165016475 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; A quick and dirty Oaklisp file linker. ;;; (C) Barak A. Pearlmutter and Kevin J. Lang, Fall 1986, Winter 1992. ;;; Potential bugs noticed while porting: ;;; ;;; count-variable calls count-symbol always. Count-symbol always allocates ;;; storage, even if the symbol already exists. Is this a core leak? ; the input to this program is a bunch of files, each of which ; contains a big list whose format is ; ; (( ; ((constant 14 ((foo bar) baz)) ; (variable 2 append) ; these offsets are ; (code 28 6)) ; in terms of 16 shortwords ; (100 343 232 ... ) ; 16 bit opcodes ; ) ; ( ; another code block ; ) ; ) (define cell-size 1) (define pair-size 3) (define symbol-size 2) (define method-size 3) (define null-size 1) (define t-size 1) (define type-size 9) (define coercable-type-size 10) (define int-tag 0) (define imm-tag 1) (define loc-tag 2) (define ptr-tag 3) (define return-opcode (* 24 256)) (define noop-opcode 0) (define value-stack-size #x1abc) (define context-stack-size #x2abc) (set! world-array-size 0) (define cache-pairs? #t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;macros for speed ; Not any more --BAP ; this code depends on bignums (define (tagize-int x) (+ int-tag (* 4 (if (negative? x) (+ x (expt 2 30)) x)))) (define (tagize-imm x) (+ imm-tag (ash-left x 2))) (define (tagize-ptr x) (+ ptr-tag (ash-left x 2))) (define (tagize-loc x) (+ loc-tag (ash-left x 2))) (define (store-world-int x word-addr) (store-world-word (tagize-int x) word-addr)) (define (store-world-ptr x word-addr) (store-world-word (tagize-ptr x) word-addr)) (define (store-world-loc x word-addr) (store-world-word (tagize-loc x) word-addr)) (define (zero-enough? x) (destructure** x ('0 #t) (('0 . '0) #t) (otherwise #f))) (define (store-world-word word word-addr) (let ((oldword (nth world word-addr))) (if (zero-enough? oldword) (set! (nth world word-addr) word) (error "Attempt to overwrite <~s ~s>." word word-addr)))) (define (store-world-opcodes o1 o2 word-addr) (store-world-word (cons o1 o2) word-addr)) ;;; End of what used to be macros for speed ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;top level stuff ; (set! stashed-inlist #f) (set! var-table #f) ;impose an ordering on variables (set! var-list #f) (set! blk-table #f) (set! sym-table #f) (set! pair-table #f) (set! the-empty-string #f) (define (init-tables) (set! var-list '()) (set! the-empty-string #f) (set! var-table (make-eq-hash-table)) (set! blk-table (make-eq-hash-table)) (set! sym-table (make-eq-hash-table)) (set! pair-table (make-equal-hash-table))) (define (tool-files in-files out-file) (format #t "reading ...") (let ((in-names (map (lambda (na) (extensionize na ".oa")) in-files))) (tool (map (lambda (name) (format #t " ~a" name) (flush standard-output) (read-oa-file name)) in-names) in-files) (format #t "~%") (dump-tables (extensionize out-file ".sym")) (format #t "symbol-table~%") (dump-world (extensionize out-file ".cold")) (cons 'world out-file))) (define (tool inlist in-names) (set! stashed-inlist inlist) (init-tables) (count-things inlist) (format #t "counts~%") (compute-base-addresses) (format #t "base-addrs~%") (init-world) (format #t "world-init~%") (layout-symbols-and-variables) (format #t "syms-and-vars~%") (layout-handbuilt-data) (format #t "handbuilt~%") (patch-symbols) (format #t "symbol-patches~%") (build-blk-table inlist) (format #t "blk-table~%") (spew-opcodes inlist in-names) (format #t "opcodes~%") (set! stashed-inlist #f) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;first pass ; count everything ; initialize symbol and variable tables (define reg-code-delta 4) ;extra opcode units per block (define top-code-delta -2) ;in actual world (set! blk-count 0) (set! opc-count 0) (set! var-count 0) (set! sym-count 0) (set! dat-count 0) ;words (set! max-blks 0) ;most blocks in one file ; (define (count-things inlist) (set! dat-count 0) (set! blk-count 0) (set! opc-count (- reg-code-delta top-code-delta)) ; header for top code blk (for-each count-variable vars-to-preload) (dolist (fil inlist) (let ((nblks (length fil))) (set! opc-count (+ opc-count (+ top-code-delta (* reg-code-delta (- nblks 1))))) (set! max-blks (max nblks max-blks)) (set! blk-count (+ nblks blk-count)) (dolist (blk fil) (print-dot) (count-opcodes blk) (dolist (x (first blk)) (let ((keyword (first x))) (cond ((eq? 2 keyword) ;constant (count-data (third x))) ((eq? 0 keyword) ;variable (count-variable (third x))) ((eq? 1 keyword) ;code ;;noop ) (else (error "bad inline patch keyword ~S.~&" keyword)))))))) (set! var-list (reverse! var-list)) (set! var-count (length var-table)) (set! sym-count (length sym-table)) (set! dat-count (+ dat-count (handbuilt-data-size))) (format #t "~&ops:~s vars:~s syms:~s cells:~s~%" opc-count var-count sym-count dat-count)) (define (count-opcodes blk) (let ((op-co (length (second blk)))) (if (odd? op-co) (error "<~s> odd # of opcodes is ~n ~&" op-co blk)) (set! opc-count (+ opc-count op-co)))) (define (count-variable v) (if (not (toble-probe v var-table)) (push var-list v)) (count-symbol v)) (define (count-symbol v) (set! dat-count (+ (string-size (#^string v)) dat-count)) (toble-probe v sym-table)) (define (count-data d) (cond ((symbol? d) (count-symbol d)) ((number? d) ) ((char? d) ) ((null? d) ) ((eq? d '#t) ) ((pair? d) (set! dat-count (+ pair-size dat-count)) (count-data (car d)) (count-data (cdr d))) ((string? d) (set! dat-count (+ (string-size d) dat-count))) (else (error "count: bad inline constant <~s> ~&" d)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;second pass ; layout symbols and variables ; build block table (set! start-of-opc-space 0) (set! start-of-var-space 0) (set! start-of-sym-space 0) (set! start-of-dat-space 0) (set! next-free-dat 0) (define (compute-base-addresses) (set! start-of-opc-space 0) (set! start-of-var-space (+ start-of-opc-space (quotient opc-count 2))) (set! start-of-sym-space (+ start-of-var-space (* var-count cell-size))) (set! start-of-dat-space (+ start-of-sym-space (* sym-count symbol-size))) (set! world-array-size (+ start-of-dat-space dat-count)) (set! next-free-dat start-of-dat-space)) (define (alloc-dat n) (let ((old-addr next-free-dat)) (set! next-free-dat (+ next-free-dat n)) (if (> next-free-dat world-array-size) (space-error 'data) old-addr))) (define (layout-symbols-and-variables) (let ((nextvar start-of-var-space) (nextsym start-of-sym-space)) (dolist (name var-list) (toble-set name nextsym sym-table) (set! nextsym (+ nextsym symbol-size)) (toble-set name nextvar var-table) (set! nextvar (+ nextvar cell-size))) (toble-walk (lambda (name addr) (if (not addr) (block (toble-set name nextsym sym-table) (set! nextsym (+ nextsym symbol-size))))) sym-table))) (define (patch-symbols) (toble-walk (lambda (name addr) (store-world-ptr where-nil-lives addr) (store-world-word (string-alloc (#^string name)) (+ 1 addr))) sym-table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; The blk table is a little strange. ; Its keys are special code numbers computed by uniq-blkno. ; The entries are conses (addr . kind), where kind says ; what sort of code munching needs to be done to append the ; top level blocks. (set! first-regular-blk-addr 0) (define (uniq-blkno filno blkno) (+ blkno (* max-blks filno))) (define (build-blk-table inlist) (let* ((nfils (length inlist)) (next-blk-addr (+ start-of-opc-space (quotient (- reg-code-delta top-code-delta) 2))) (allocate-blk (lambda (blk toplevelp) (let ((old-addr next-blk-addr) (nwords (quotient (+ (length (second blk)) (if toplevelp top-code-delta reg-code-delta)) 2))) (set! next-blk-addr (+ next-blk-addr nwords)) (if (> next-blk-addr start-of-var-space) (space-error 'code) old-addr))))) (dolist-count (fils inlist filno) (let ((blk (first fils))) (set! (contents (toble-install (uniq-blkno filno 0) blk-table)) (cons (allocate-blk blk #t) (if (= filno (- nfils 1)) 'lastoplevel 'toplevel))))) (set! first-regular-blk-addr next-blk-addr) (dolist-count (fils inlist filno) (dolist-count (blk (cdr fils) blknom1) (set! (contents (toble-install (uniq-blkno filno (+ 1 blknom1)) blk-table)) (cons (allocate-blk blk #f) 'regular)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;third pass ; throw code out into the world (define (spew-opcodes inlist in-names) (format #t " spew") (store-world-ptr where-%code-vector-lives start-of-opc-space) (store-world-int first-regular-blk-addr (+ 1 start-of-opc-space)) (store-world-ptr where-nil-lives (+ 2 start-of-opc-space)) (do ((fils inlist (cdr fils)) (filno 0 (+ filno 1)) (in-names in-names (and (not (null? in-names)) (cdr in-names)))) ((null? fils)) (if in-names (format #t " ~A" (car in-names)) (format #t "?")) (flush standard-output) (dolist-count (blk (first fils) blkno) (print-dot) (let* ((patches (first blk)) (opcodes (second blk)) (info (toble-get (uniq-blkno filno blkno) blk-table)) (base-addr (car info)) (blk-kind (cdr info)) (regp (eq? blk-kind 'regular)) (delta (quotient (if regp reg-code-delta top-code-delta) 2)) (delbase-addr (+ delta base-addr))) (when regp (store-world-ptr where-%code-vector-lives base-addr) (store-world-int (+ 2 (quotient (length opcodes) 2)) (+ 1 base-addr))) (iterate opStep ((ops opcodes)(addr delbase-addr)) (cond (ops (when (>= addr base-addr) (store-world-opcodes (first ops) (second ops) addr)) (opStep (cddr ops) (+ 1 addr))) ((eq? 'toplevel blk-kind) (changereturntonoop (- addr 1))))) (dolist (pat patches) (let* ((patkind (first pat)) (pataddr (+ delbase-addr (quotient (second pat) 2))) (patval (third pat)) (patref (cond ((eq? 2 patkind) (constant-refgen patval)) ((eq? 0 patkind) (tagize-loc (toble-get patval var-table))) ((eq? 1 patkind) (tagize-ptr (car (toble-get (uniq-blkno filno patval) blk-table)))) (else (error "Unknown patkind in pat ~S." pat))))) (when (>= pataddr base-addr) (store-world-word patref pataddr))))))) (format #t "~%")) ;this is a hack to string the top-level blocks together (define (changereturntonoop addr) (let* ((them (get-world-opcodes addr)) (op1 (car them)) (op2 (cdr them))) (cond ((= op2 return-opcode) (overwrite-world-opcodes op1 noop-opcode addr)) ((and (= op1 return-opcode) (= op2 noop-opcode)) (overwrite-world-opcodes noop-opcode noop-opcode addr)) (else (error "bad ops in toplvl blk end <~s ~s> ~&" op1 op2))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;cons up inline constants ; (define (constant-refgen c) (cond ((symbol? c) (tagize-ptr (toble-get c sym-table))) ((null? c) (tagize-ptr where-nil-lives)) ((eq? c '#t) (tagize-ptr where-t-lives)) ((number? c) (tagize-int c)) ((char? c) (tagize-imm (ash-left (#^number c) 6))) ((pair? c) (if cache-pairs? (caching-pair-alloc c) (pair-alloc c))) ((string? c) (string-alloc c)) (else (error "refgen: bad constant data <~s> ~&" c)))) (define (pair-alloc c) (let ((newpair (alloc-dat pair-size))) (store-world-ptr where-cons-pair-lives newpair) (store-world-word (constant-refgen (car c)) (+ 1 newpair)) (store-world-word (constant-refgen (cdr c)) (+ 2 newpair)) (tagize-ptr newpair))) (define (caching-pair-alloc c) (cond ((present? pair-table c) => cdr) (else (let ((newp (pair-alloc c))) ;; Note that this code assumes that C is not EQUAL? to any of its ;; subexpressions. (set! (present? pair-table c) newp) newp)))) (define (string-size c) (let* ((strlen (length c)) (strwordlen (+ 3 (quotient (+ strlen (- 3 1)) 3)))) strwordlen)) (define (string-alloc c) (let ((strlen (length c))) (if (> strlen 0) (real-string-alloc c strlen) (or the-empty-string (let ((e-s (real-string-alloc c strlen))) (set! the-empty-string e-s) e-s))))) (define (real-string-alloc c strlen) (let* ((strwordlen (+ 3 (quotient (+ strlen (- 3 1)) 3))) (newstring (alloc-dat strwordlen)) (strlist (map #^number (#^list-type c)))) (store-world-ptr where-string-lives newstring) (store-world-int strwordlen (+ 1 newstring)) (store-world-int strlen (+ 2 newstring)) (string-alloc-aux (+ 3 newstring) strlist strlen) (tagize-ptr newstring))) (define (string-alloc-aux i l to-do) (iterate aux ((i i)(l l)(to-do to-do)) (cond ((= to-do 0) ) ((= to-do 1) (store-world-int (car l) i)) ((= to-do 2) (store-world-int (bit-or (car l) (ash-left (cadr l) 8)) i)) (else (let* ((c0 (car l)) (l1 (cdr l)) (c1 (car l1)) (l2 (cdr l1)) (c2 (car l2))) (store-world-int (bit-or c0 (bit-or (ash-left c1 8) (ash-left c2 16))) i) (aux (+ i 1) (cdr l2) (- to-do 3))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;hand-built things ; (define vars-to-preload '(nil t cons-pair %code-vector string %%symloc %%nsyms %%symsize %%varloc %%nvars)) (set! where-nil-lives #f) (set! where-t-lives #f) (set! where-string-lives #f) (set! where-cons-pair-lives #f) (set! where-%code-vector-lives #f) (set! where-boot-method-lives #f) (define (handbuilt-data-size) (+ null-size t-size method-size (* 2 type-size) (* 1 coercable-type-size))) (define (layout-handbuilt-data) (set! where-nil-lives (alloc-dat null-size)) (set! where-t-lives (alloc-dat t-size)) (set! where-string-lives (alloc-dat coercable-type-size)) (set! where-cons-pair-lives (alloc-dat type-size)) (set! where-%code-vector-lives (alloc-dat type-size)) (store-world-ptr where-nil-lives (toble-get 'nil var-table)) (store-world-ptr where-t-lives (toble-get 't var-table)) (store-world-ptr where-string-lives (toble-get 'string var-table)) (store-world-ptr where-cons-pair-lives (toble-get 'cons-pair var-table)) (store-world-ptr where-%code-vector-lives (toble-get '%code-vector var-table)) (store-world-loc start-of-sym-space (toble-get '%%symloc var-table)) (store-world-loc start-of-var-space (toble-get '%%varloc var-table)) (store-world-int sym-count (toble-get '%%nsyms var-table)) (store-world-int var-count (toble-get '%%nvars var-table)) (store-world-int symbol-size (toble-get '%%symsize var-table)) (layout-boot-method) ) (define (layout-boot-method) (set! where-boot-method-lives (alloc-dat method-size)) (store-world-ptr where-nil-lives where-boot-method-lives) (store-world-ptr start-of-opc-space (+ 1 where-boot-method-lives)) (store-world-ptr where-nil-lives (+ 2 where-boot-method-lives)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;random junk ; (define (space-error which) (error "Out of ~s space." which)) (define (print-dot) (write-char standard-output #\.) (flush standard-output)) (define (pw) (dotimes (i (length world)) (format #t "~s " (nth world i)))) (define (extensionize base ext) (append (downcase (#^string base)) ext)) (define (read-oa-file file) ;file already has an extension (let ((red (read-file file))) (cond ((not (null? (cdr red))) (error "File ~S, should contain but one form, but has ~A." file (length red))) ((and (pair? (car (car red))) (pair? (caar (car red)))) (car red)) (else (make-oa-list (car red)))))) (define (make-oa-list oaf-list) (let ((sym-vec (#^simple-vector (first oaf-list)))) (labels (((rewrite-syms clause) (let ((car-clause (car clause))) (if (> car-clause (- 5 1)) (list (- car-clause 5) (second clause) (nth sym-vec (third clause))) clause)))) (map! (lambda (blk) (list (map! rewrite-syms (triplify! (first blk))) (second blk))) (second oaf-list))))) ; this function reverses the order of the triples. ; also, it is extremely side-effecting, so watch out. (define (triplify! inlist) (iterate step ((in inlist) (out '())) (if in (let* ((cddrin (cdr (cdr in))) (nxtrip (cdr cddrin))) (step nxtrip (block (set! (cdr cddrin) nil) (cons in out)))) out))) ;;; Note: the caller of PRINT-HEX must bind (FLUID PRINT-RADIX) to 16 ;;; or results are unpredictable. (define (print-hex num ndigits outfile) (cond ((not ndigits) (when (or (negative? num) (and (not (eq? (get-type num) fixnum)) (> num #xffffffff))) (error "Can't PRINT-HEX #x~X with ~D digits" num ndigits))) ((= ndigits 4) (cond ((negative? num) (error "Can't PRINT-HEX #x~X with ~D digits" num ndigits)) ((< num #x10) (write-char outfile #\0) (write-char outfile #\0) (write-char outfile #\0)) ((< num #x100) (write-char outfile #\0) (write-char outfile #\0)) ((< num #x1000) (write-char outfile #\0)) ((> num #xffff) (error "Can't PRINT-HEX #x~X with ~D digits" num ndigits)))) (else (error "Can't PRINT-HEX #x~X with ~D digits" num ndigits))) (print num outfile)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;test stuff ; (define testlist '( ( ; start of file 1 ( ; start of block ((constant 6 ((foo bar) 1)) (code 10 1) (constant 0 ()) (variable 2 append)) (0 0 0 0 100 343 0 0 232 1 0 0 2 3 4 5 5 6 7 6144) ;18 ) ; end of block ( ; start of block ((constant 4 12) (constant 0 (ivar1 ivar2)) (constant 6 dog) (variable 10 dog)) (0 0 2 3 0 0 0 0 100 343 0 0 54 23 6144 0) ;14 ) ; end of block ) ; end of file ( ; start of file 2 ( ; start of block ((constant 0 ()) (variable 2 nil) (variable 4 foo)) (0 0 0 0 0 0 9 8 7 6 5 6144) ;12 ) ; end of block ) ;end of file ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;world accessor functions ; (set! world nil) ;this holds an array of words. ;opcodes are stored as pairs. (define (init-world) (let ((array-size world-array-size)) (set! world (make simple-vector array-size)) (dotimes (i array-size) (set! (nth world i) 0)))) (define (overwrite-world-opcodes o1 o2 word-addr) (set! (nth world word-addr) (cons o1 o2))) (define (overwrite-world-word word word-addr) (set! (nth world word-addr) word)) (define (get-world-word word-addr) (nth world word-addr)) (define (get-world-opcodes word-addr) (nth world word-addr)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;write output files ; (define (dump-world filename) (let ((actual-size next-free-dat) (world world)) (with-open-file (outfile filename out) (write-world-header outfile) (bind ((#*print-radix 16)) (dotimes (i actual-size) (when (zero? (modulo i 8)) (format outfile "~%")) (let ((guy (nth world i))) (cond ((number? guy) (write-char outfile #\space) (print-hex guy #f outfile)) ((pair? guy) (write-char outfile #\^) (print-hex (car guy) #f outfile) (print-hex (cdr guy) 4 outfile)) (else (error "Unknown guy ~S." guy)))))) ;; Size of weak-pointer table: (format outfile "~%0~%")) (format #t "~&Total words:~D~%" actual-size))) (define (write-world-header outfile) (bind ((#*print-radix 16)) (print-hex value-stack-size #f outfile) (format outfile " ") (print-hex context-stack-size #f outfile) (format outfile " ") (print-hex (tagize-ptr where-boot-method-lives) #f outfile) (format outfile " ") (print-hex next-free-dat #f outfile) (format outfile "~%"))) (define (dump-tables filename) (write-file filename `((variables ,(ordered-toble->alist var-table var-list)) (symbols ,(reverse (toble->alist sym-table)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; toble stuff ; (define (toble-install key toble) (if (toble-probe key toble) (error "Key ~S already installed in table ~S." key toble) (toble-probe key toble))) (define (toble-get key toble) (let ((slot (toble-probe key toble))) (if (not slot) (error "Key ~S not found in table ~S." key toble) (contents slot)))) (define (toble-set key value toble) (let ((slot (toble-probe key toble))) (if (not slot) (error "Key ~S not found in table ~S." key toble) (set! (contents slot) value)))) ;;; BAP: TOBLE-PROBE used to be a macro for speed. (define (toble-probe key toble) (cond ((table-entry toble key)) (else (set! (table-entry toble key) (%make-cell nil)) #f))) ;;; BAP: Fix quick fix. (define (toble-walk lamder toble) ;; LAMDER is to be applied to each key,value pair. (dolist (a (#^list-type toble)) (lamder (car a) (contents (cdr a))))) (define (toble->alist toble) (map (lambda (x) `(,(car x) ,(contents (cdr x)))) (#^list-type toble))) (define (ordered-toble->alist toble keylist) (map (lambda (key) (cons key (contents (table-entry toble key)))) keylist)) (define (toble-clear x) (set! (length x) 0)) oaklisp-1.3.3.orig/src/world/mix-types.oak0000664000175000000620000000355107725515165017453 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Define mixin management tools. ;; (define-instance mixin-manager type '(type-alist) (list object)) (add-method (initialize (mixin-manager type-alist) self) (set! type-alist '()) self) (define-instance mix-types operation) (add-method (mix-types (mixin-manager type-alist) self types) ;; Run through the list looking for what we want. (iterate aux ((l type-alist)) (if (null? l) ;; not on list, make it. (let ((newtype (make type '() types))) (set! type-alist (cons (cons types newtype) type-alist)) newtype) ;; We want to write test (EQUAL? TYPES (CAAR L)) here, but ;; EQUAL? doesn't work yet so the comparison is done inline, ;; element by element. (labels ((non-equal-exit (lambda () (aux (cdr l))))) (iterate loop ((x types) (y (caar l))) (cond ((null? x) (if (null? y) ;; They are equal, return the right type: (cdar l) (non-equal-exit))) ((or (null? y) (not (eq? (car x) (car y)))) (non-equal-exit)) (else (loop (cdr x) (cdr y))))))))) ;;; eof oaklisp-1.3.3.orig/src/world/sequences.oak0000664000175000000620000001307307725515165017507 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter (add-method (subsequence? (sequence) s1 s2) (let* ((l1 (length s1)) (l2 (length s2)) (ldiff (- l2 l1))) (iterate loop2 ((i2 0)) (if (> i2 ldiff) #f (iterate loop1 ((i1 0)) (if (>= i1 l1) i2 (if (eq? (nth s1 i1) (nth s2 (+ i1 i2))) (loop1 (1+ i1)) (loop2 (1+ i2))))))))) ;;; NOTE: the following definition would make two identical vectors, where ;;; one of them is an odd lazy-evaluating kind, not be equal, which is bad. ;;; Having a SEQUENCE-TYPE operation which returns the right "high level" ;;; sequence type might work. (add-method (equal? (sequence) a b) (or (eq? a b) (and (eq? (get-type a) (get-type b)) (let ((l (length a))) (and (= l (length b)) (or (zero? l) (let ((lm1 (- l 1))) (iterate aux ((i 0)) (cond ((= i lm1) (equal? (nth a lm1) (nth b lm1))) ((equal? (nth a i) (nth b i)) (aux (+ i 1))) (else #f)))))))))) (add-method (fill! (sequence) self val) (dotimes (i (length self) self) (set! (nth self i) val))) ;;; Note: this must be shadowed for list-type, since you can make neither ;;; cons-pair nor null-type with this interface. (add-method (reverse (sequence) self) (let* ((len (length self)) (new (make (get-type self) len)) (len-1 (- len 1))) (dotimes (i len new) (set! (nth new i) (nth self (- len-1 i)))))) (add-method (reverse! (sequence) self) (let ((len (length self))) (iterate aux ((a 0) (b (- len 1))) (cond ((<= a b) (let ((x (nth self a))) (set! (nth self a) (nth self b)) (set! (nth self b) x) (aux (+ a 1) (- b 1)))) (else self))))) (add-method (copy (sequence) self) (let* ((len (length self)) (new (make (get-type self) len))) (dotimes (i len new) (set! (nth new i) (nth self i))))) #| (add-method (append (sequence) s1 s2) (let* ((len1 (length s1)) (len2 (length s2)) (len (+ len1 len2)) (new (make (get-type s1) len))) (dotimes (i len1) (set! (nth new i) (nth s1 i))) (dotimes (i len2 new) (set! (nth new (+ i len1)) (nth s2 i))))) |# ; this method contains an internal special case for simple-vectors (add-method (append (sequence) . rest) (listify-args (lambda (args) (let* ((lens (map length args)) (car-type (get-type (car args))) (new-guy (make car-type (apply + lens))) (new-guy-setter (if (eq? car-type simple-vector) (setter %vref-nocheck) (setter nth)))) (iterate outerloop ((sources args) (lens lens) (offset 0)) (if (null? sources) new-guy (if (subtype? (get-type (car sources)) forcible) (outerloop (cons (force (car sources)) (cdr sources)) lens offset) (let* ((source (car sources)) (source-type (get-type source)) (source-accessor (if (eq? simple-vector source-type) %vref-nocheck nth)) (len (car lens))) (when (not (eq? car-type source-type)) (append-type-error car-type source)) (iterate innerloop ((from 0)(to offset)) (if (= from len) (outerloop (cdr sources)(cdr lens)(+ offset len)) (block (new-guy-setter new-guy to (source-accessor source from)) (innerloop (1+ from)(1+ to))))))))))) . rest)) (add-method (subseq (sequence) self index len) (let ((new (make (get-type self) len))) (dotimes (i len new) (set! (nth new i) (nth self (+ index i)))))) ;;; Sometimes one wants two indexes rather than an index and a length. ;;; SUBSEQ-INDEXES takes and sequence and two indices. It returns the ;;; subsequence from START (inclusive) to END (exclusive). (define (subseq-indexes seq start end) (subseq seq start (- end start))) (add-method (tail (sequence) self index) (subseq self index (- (length self) index)) ;(let* ((len (length self)) ; (nlen (- len index)) ; (new (make (get-type self) nlen))) ; (dotimes (i nlen new) ; (set! (nth new i) (nth self (+ index i))))) ) (labels ((copy-first-chunk (lambda (l i) (if (zero? i) '() (cons (car l) (copy-first-chunk (cdr l) (- i 1))))))) (add-method (subseq (list-type) self index len) (copy-first-chunk (tail self index) len))) ;;; From beginning to INDEX (exclusive). (add-method (head (sequence) self index) (subseq-indexes self 0 index)) (add-method (last (sequence) self) (nth self (- (length self) 1))) (add-method (#^list-type (sequence) v) (let ((len (length v))) (iterate aux ((i (- len 1))(l '())) (if (= i -1) l (aux (- i 1) (cons (nth v i) l)))))) ;;; Selection (add-method (remove (pair) x y) (if (eq? (car x) y) (remove (cdr x) y) (cons (car x) (remove (cdr x) y)))) (add-method (remove (null-type) x y) x) (add-method (remove-if (pair) x pred) (if (pred (car x)) (remove-if (cdr x) pred) (cons (car x) (remove-if (cdr x) pred)))) (add-method (remove-if (null-type) x pred) x) ;;; eof oaklisp-1.3.3.orig/src/world/bounders.oak0000664000175000000620000000364107725515165017335 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter (define-instance find-bound-vars operation) (define-instance find-vars operation) (define-instance for-each-r operation) (add-method (for-each-r (eq-hash-table table) self op) (let ((op (lambda (x) (op (car x) (cdr x))))) (dotimes (i (length table)) (for-each op (nth table i))))) (add-method (find-bound-vars (locale variable-table) self val) (for-each-r variable-table (lambda (sym cell) (when (eq? (contents cell) val) (format #t "~&~A's bound to that.~%" sym))))) (add-method (find-vars (locale variable-table) self pred?) (for-each-r variable-table (lambda (sym cell) (when (pred? (contents cell) sym) (format #t "~&~A (~A)~%" sym (contents cell)))))) (define-instance find-sorted-vars operation) (add-method (find-sorted-vars (locale variable-table) self pred?) (let ((outlist nil)) (for-each-r variable-table (lambda (sym cell) (when (pred? (contents cell) sym) (push outlist sym)))) (sort outlist (lambda (a b) (< (#^string a) (#^string b)))))) (define (find-and-print-sorted-vars locale pred?) (dolist (x (find-sorted-vars locale pred?)) (format #t "~&~A~%" x))) oaklisp-1.3.3.orig/src/world/cmdline-options.oak0000664000175000000620000000465310752550372020615 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1999 Barak A. Pearlmutter. (define commandline-options `(("help" 0 ,(lambda () (format #t " Oaklisp level options. --help Print this message & exit. --eval expr Evaluate Oaklisp expression, which is one arg so be sure to quote for shell. --load file Load a file. --compile file Compile file.oak yielding file.oa --locale x Switch to locale x, eg system-locale (default), compiler-locale, scheme-locale (for RnRS compatibility). --pthreads Number of pthreads to allocate. --exit Exit upon processing this option. Example: oaklisp --trace-gc 2 -- --locale scheme-locale --compile myfile --exit ") (exit 0))) ("eval" 1 ,(lambda (x) (eval (read (make string-input-stream x)) #*current-locale))) ("load" 1 ,(lambda (x) (load x #*current-locale))) ("compile" 1 ,(lambda (x) (format #t "~&Compiling ~S..." x) (flush standard-output) (bind ((#*compiler-noisiness 0)) (compile-file #*current-locale x)) (format #t "...done.~%"))) ("locale" 1 ,(lambda (x) (set! #*current-locale (eval (read (make string-input-stream x)) #*current-locale)))) ("pthreads" 1 ,(lambda (x) (set! heavyweight-thread-count (read (make string-input-stream x))) (unless (integer? heavyweight-thread-count) (exit 1 "-pthread option takes integer argument.~%")))) ("exit" 0 ,(lambda () (exit 0 ""))))) (define (cmdline-eat) (set! argline (getopt commandline-options argline))) (add-warm-boot-action cmdline-eat) oaklisp-1.3.3.orig/src/world/eqv.oak0000664000175000000620000000164307725515165016307 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter (define-constant eqv? (add-method ((make (mix-types oc-mixer (list foldable-mixin operation))) (object) x y) (eq? x y))) ;;; eof oaklisp-1.3.3.orig/src/world/print-list.oak0000664000175000000620000000602107725515165017614 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;;; A hairy print method for lists. With abbreviation, hooks for using this ;;; code to print vectors, etc. (add-method (print (null-type) self stream) (write-char stream #\() (write-char stream #\))) ;;; Print methods for lists. The trick here is a helper function, ;;; PRINT-LIST-END, which prints the tail of a list. It takes a second ;;; argument which is true if a delimiter (ie white space or "(") was ;;; just printed, a third which is the number of elements printed so fat, ;;; and a fourth which is a string to close the list with, normally ")". (set! #*print-level #f) (set! #*print-length #f) (set! #*print-escape #t) (set! #*print-radix 10) (define-instance print-list-end operation) ;;; Note: the code below is duplicated to some extent in the methods for ;;; pretty-print for pairs in print-pretty.oak, so if the code below is hacked ;;; the hacks should be copied over. (add-method (print (pair) self stream) (if (and #*print-level (<= #*print-level 0)) (write-char stream #\#) (let ((the-car (car self))) (bind ((#*print-level (and #*print-level (- #*print-level 1)))) (cond ((and (quotelike-prefix? the-car) (pair? (cdr self)) (null? (cddr self))) (write-char stream (quotelike-prefix? the-car)) (print (cadr self) stream)) ((and (eq? the-car 'unquote-splicing) (pair? (cdr self)) (null? (cddr self))) (write-string ",@" stream) (print (cadr self) stream)) ((and (eq? the-car 'unquote) (pair? (cdr self)) (null? (cddr self))) (write-char stream #\,) (print (cadr self) stream)) (else (write-char stream #\() (print-list-end self #t #*print-length ")" stream))))))) (add-method (print-list-end (object) self delimiter? len ending stream) (write-string " . " stream) (print self stream) (write-string ending stream)) (add-method (print-list-end (null-type) self delimiter? len ending stream) (write-string ending stream)) (add-method (print-list-end (pair) self delimiter? len ending stream) (when (not delimiter?) (write-char stream #\space)) (cond ((and len (= len 0)) (write-string "..." stream) (write-string ending stream)) (else (print (car self) stream) (print-list-end (cdr self) #f (and len (- len 1)) ending stream)))) ;;; eof oaklisp-1.3.3.orig/src/world/kernel0.oak0000664000175000000620000000627407725515165017061 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Barak A. Pearlmutter & Kevin J. Lang ;;; This is the lowest level kernel code in Oaklisp. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Set up some registers. (set! ((%register 'nil)) (the-runtime nil)) (set! ((%register 't)) (the-runtime t)) (set! ((%register 'cons-type)) (the-runtime cons-pair)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Make TYPE (let ((type0 (%allocate nil 9))) (set! ((%slot 0) type0) type0) (set! ((%slot 1) type0) 9) ;instance-length (set! ((%slot 2) type0) nil) ;var-length? (set! ((%slot 4) type0) ;ivar-list '(instance-length variable-length? supertype-list ivar-list ivar-count type-bp-alist operation-method-alist top-wired?)) (set! ((%slot 5) type0) 8) ;ivar-count (set! ((%slot 6) type0) '()) ;type-bp-alist (set! ((%slot 7) type0) '()) ;op-meth-alist (set! ((%slot 8) type0) 't) ;top-wired? (set! type type0)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Make OBJECT (let ((object0 (%allocate type 9))) (set! ((%slot 1) object0) 1) ;instance-length (set! ((%slot 2) object0) nil) ;var-length? (set! ((%slot 3) object0) '()) ;supertype-list (set! ((%slot 4) object0) '()) ;ivar-list (set! ((%slot 5) object0) 0) ;ivar-count (set! ((%slot 6) object0) (cons (cons object0 1) '())) ;type-bp-alist (set! ((%slot 7) object0) '()) ;op-meth-alist (set! ((%slot 8) object0) nil) ;top-wired? (set! object object0)) ;;; tell the machine where object lives. (set! ((%register 'object-type)) (the-runtime object)) ;;; Back patch the supertypes of TYPE (set! ((%slot 3) type) (cons object '())) ;;; Back patch TYPE's TYPE-BP-ALIST (set! ((%slot 6) type) (list (cons type 1) (cons object 9))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Make OPERATION (let ((operation0 (%allocate type 9))) (set! ((%slot 1) operation0) %simple-operation-length) ;instance-length (set! ((%slot 2) operation0) nil) ;var-length? (set! ((%slot 3) operation0) ;supertype-list (cons object '())) (set! ((%slot 4) operation0) '(lambda? cache-type cache-method cache-type-offset)) ;ivar-list (set! ((%slot 5) operation0) (- %simple-operation-length 1)) ;ivar-count (set! ((%slot 6) operation0) ;type-bp-alist (cons (cons operation0 1) (cons (cons object 0) '()))) (set! ((%slot 7) operation0) '()) ;op-meth-alist (set! ((%slot 8) operation0) t) ;top-wired? (set! operation operation0)) oaklisp-1.3.3.orig/src/world/kernel1-inittypes.oak0000664000175000000620000000261107725515165021077 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang and Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; time to back patch some types (set! variable-length-mixin (make type '() '())) (initialize %closed-environment '() (list variable-length-mixin object)) (%your-top-wired %closed-environment) ;this provides no protection (initialize %code-vector '(ivar-map) (list variable-length-mixin object)) (%your-top-wired %code-vector) ;this provides no protection (initialize %method '(the-code the-environment) (list object)) (add-method (initialize (%method the-code the-environment) self c e) (set! the-code c) (set! the-environment e) self) oaklisp-1.3.3.orig/src/world/has-method.oak0000664000175000000620000000237207725515165017545 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang ;;; Define the has-method? operation. (define (has-method? typ op) (let ((it (%get-an-ivar operation op 'lambda?))) (and (not (eq? it 0)) (or (and it (subtype? typ object)) (really-has-method? typ op))))) (define-instance really-has-method? operation) (add-method (really-has-method? (type supertype-list operation-method-alist) self op) (or (%assq op operation-method-alist) (any? (lambda (typ) (really-has-method? typ op)) supertype-list))) ;;; eof oaklisp-1.3.3.orig/src/world/gc.oak0000664000175000000620000000230607725515165016102 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter (define-constant %gc (add-method ((make-open-coded-operation '((gc)) 0 1) (object)) (%gc))) (define-constant %full-gc (add-method ((make-open-coded-operation '((full-gc)) 0 1) (object)) (%full-gc))) ;;; Maybe there should be an interface to the next-newspace-size register ;;; here. And maybe RECLAIM_FRACTION should be a register with an interface ;;; here instead of a C compile-time constant. ;;; eof oaklisp-1.3.3.orig/src/world/multi-off.oak0000664000175000000620000000165707725515165017423 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; This is to guard all usage of thread-related functions so they don't ;;; get used during the cold boot process. In particular: fluids. ;;; Set this to FALSE when threading is turned on. (define %no-threading 0) oaklisp-1.3.3.orig/src/world/reader.oak0000664000175000000620000001720607725515165016760 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter ;;; Code to read character sequences and produce Oaklisp objects. Common Lisp ;;; compatible where convenient. ;;; Reader syntax table: (define-instance read-table type '() (list simple-vector)) ;;; The nth method for read tables is pretty inner loopy, so the call ;;; to #^number has been removed in favor of open code. (add-method (nth (read-table) self char) (%vref-nocheck self (ash-left (%data char) -6) ; (#^number char) )) (add-method ((setter nth) (read-table) self char val) (set! (%vref self (#^number char)) val)) ; this name is short for "vref with character index" (define-constant-instance %vref/ci operation) (add-method (%vref/ci (variable-length-mixin) self char) (%load-bp-i (ash-left (%data char) -6))) (define-instance standard-read-table read-table 256) ;;; Read table entries are: ;;; WHITESPACE ;;; CONSTITUENT ;;; SINGLE-ESCAPE ;;; ILLEGAL ;;; (TERMINATING-MACRO . operation) ;;; (NONTERMINATING-MACRO . operation) ;;; The MULTIPLE-ESCAPE type entry is not needed, as in the absence of ;;; packages '|' can be a simple terminating reader macro. (dotimes (c 256) (set! (nth standard-read-table c) (cond ((= c (#^number #\\)) 'single-escape) ((<= c (#^number #\space)) 'whitespace) ((<= c (#^number #\~)) 'constituent) (else 'illegal)))) ;;; A switch for turning off most computation while in a #- thing: (set! #*read-suppress #f) ;;; The canonical unread object, for being returned by things that ;;; were supposed to read something but read a nothing instead, like ;;; the #\; reader macro. (define-instance unread-type type '() (list object)) (define-simple-print-method unread-type "Unread") (define-instance the-unread-object unread-type) ;;; Blow off whitespace (define (skip-whitespace stream) (iterate aux () (let ((c (peek-char stream))) ;; The first three eq? clauses in the or is for speed, ;; and of dubious correctness, and should be benchmarked. (cond ((or (eq? c #\space) (eq? c #\tab) (eq? c #\newline) (and (not (eq? c the-eof-token)) (eq? (%vref/ci standard-read-table c) 'whitespace))) (read-char stream) (aux)) (else nil))))) ;;; Read expressions until the closing delimiter is hit, consuming it. ;;; CLOSING-DOT? tells whether improper dotted syntax is allowed. (define (read-until closing-delimiter closing-dot? stream) (iterate aux ((list-top nil)(list-ending nil)) (skip-whitespace stream) (cond ((eq? (peek-char stream) closing-delimiter) (read-char stream) list-top) (else (let ((x (subread stream))) (cond ((eq? x the-unread-object) (aux list-top list-ending)) ((eq? x the-dot-token) (cond (closing-dot? (iterate aux () (let ((x (subread stream))) (cond ((eq? x the-unread-object) (aux)) ((eq? x the-dot-token) (signal dot-in-list-end list-top '()) (aux)) ((eq? x the-eof-token) (signal eof-in-list-end list-top '()) (aux)) (else (iterate aux () (skip-whitespace stream) (cond ((eq? (peek-char stream) closing-delimiter) (read-char stream) (cond ((null? list-top) x) (else (set! (cdr list-ending) x) list-top))) (else (let ((y (subread stream))) (cond ((eq? y the-unread-object) (aux)) (else (signal extra-object-in-list-end y list-top (list x)) (aux)))))))))))) (else (signal illegal-dot-in-list list-top closing-delimiter) (aux list-top list-ending)))) ((eq? x the-eof-token) (signal eof-reading-until list-top closing-delimiter) (aux list-top list-ending)) (else (let ((nl (cons x nil))) (cond ((null? list-top) (aux nl nl)) (else (set! (cdr list-ending) nl) (aux list-top nl))))))))))) #|| ;;; The following definition has been obsoleted by the above more ;; complex but non-recursive version with better error messages. (define (read-until closing-delimiter closing-dot? stream) (iterate aux () (skip-whitespace stream) (cond ((eq? (peek-char stream) closing-delimiter) (read-char stream) '()) (else (let ((x (subread stream))) (cond ((eq? x the-unread-object) (aux)) ((eq? x the-dot-token) (cond (closing-dot? (iterate aux () (let ((x (subread stream))) (cond ((eq? x the-unread-object) (aux)) ((eq? x the-dot-token) (cerror "Ignore the dot." "Read a second '.' inside a list construct closed by ~C." closing-delimiter) (aux)) ((eq? x the-eof-token) (error "EOF reading the dotted ending of a list that was to be terminated with ~C." closing-delimiter)) (else (iterate aux () (skip-whitespace stream) (cond ((eq? (peek-char stream) closing-delimiter) (read-char stream) x) (else (let ((y (read stream))) (cond ((eq? y the-unread-object) (aux)) (else (error "Second object read after dot of a list to be terminated with ~C." closing-delimiter)))))))))))) (else (cerror "Ignore the dot." "Read a '.' inside a list construct closed by ~C ~ not allowing one." closing-delimiter) (aux)))) ((eq? c the-eof-token) (error "EOF encountered while reading a list that was to be terminated with ~C." closing-delimiter)) (else (cons x (read-until closing-delimiter closing-dot? stream))))))))) ||# ;;; And now for READ. (define (read stream) (iterate aux () (let ((obj (subread stream))) (cond ((eq? obj the-eof-token) the-eof-token) ((eq? obj the-unread-object) (aux)) ((eq? obj the-dot-token) (signal dot-outside-list) (aux)) (else obj))))) ;;; This is like READ, except that it returns the unread object or the ;;; dot token when it sees them. The functionality here was seperated ;;; out from READ to make reading list type syntax easier. (define (subread stream) (iterate aux () (let ((c (peek-char stream))) (if (eq? c the-eof-token) (read-char stream) (let ((c-syntax (%vref/ci standard-read-table c))) (cond ((eq? c-syntax 'whitespace) (read-char stream) (aux)) ((eq? c-syntax 'illegal) (error "The character ~C is illegal." (read-char stream))) ((or (eq? c-syntax 'constituent) (eq? c-syntax 'single-escape)) (read-token stream)) (else (read-char stream) ((cdr c-syntax) stream c)))))))) ;;; In order to read dotted lists correctly, the right thing to do it ;;; to return a magic thing, THE-DOT-TOKEN, when a '.' is read as a ;;; single, unescaped token. Like the unread object, this is never ;;; returned by READ. (define-instance dot-token type '() (list object)) (define-simple-print-method dot-token "dot") (define-instance the-dot-token dot-token) ;;; eof oaklisp-1.3.3.orig/src/world/mac-code.oak0000664000175000000620000003576707725515165017202 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang and Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; handy list utilities ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (swap-car-with-nth inlist n) `(,(nth inlist n) ,@(subseq inlist 1 (- n 1)) ,(car inlist) ,@(tail inlist (+ n 1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; generate code to copy args down before tail calls ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; plan-blt generates the sequence of swap,blast,and pop instructions ; that is used to copy the top of the stack down in tail recursive positions. ; (plan-blt 2 3) returns ((swap 2)(blast 4)(blast 2)), ; which converts (3 2 1 d d) to (3 2 1). (labels (((build-model old new) ;sends 2,3 to (3 2 1 d d) (reverse (append (map (lambda (d) 'd) (iota old)) (iota new)))) ((count-trash-on-top x) ; sends (d d 3 2 1 d) to (2 3 2 1 d) (iterate step ((count 0)(l x)) (if (or (null? l) (number? (car l))) (cons count l) (step (+ 1 count) (cdr l))))) ((plan-blt old new) (iterate step ((plan '())(model (build-model old new))) (cond ((= (length model) new) (reverse plan)) ((number? (car model)) (let* ((delta (- (length model) (car model))) (swapped (swap-car-with-nth model delta))) (if (number? (car swapped)) (step (cons `(swap ,delta) plan) swapped) (step (cons `(blast ,delta) plan) (cdr swapped))))) (else (let ((counted (count-trash-on-top model))) (step (cons `(pop ,(car counted)) plan) (cdr counted)))))))) (define (blt-stack n m) (cond ((zero? m) '()) ((zero? n) (list `(pop ,m))) ((> n 16) (plan-blt m n)) ;arguments reversed (else (append (make list-type (quotient m 16) `(blt-stk ,n 16)) (list `(blt-stk ,n ,(remainder m 16)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; primitive continuation definition ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;This supplies the continuation epilogue code for ;things like constants and variable references. (define-instance primitive-continuation operation) (define-instance nguys-to-pop operation) (define-instance pop-args operation) (define-instance pop-args-before-labels-jump operation) (set! #*barrier-node #f) (with-operations (number-of-args-to-pop) (add-method (number-of-args-to-pop (ast-contour-node) self) 0) (add-method (number-of-args-to-pop (ast-method-node arglist) self) (+ (length arglist) (if (and (contn-transparent? self) (not (eq? self #*barrier-node))) (number-of-args-to-pop (node-enclosing-contour self)) 0))) (add-method (number-of-args-to-pop (ast-labels-node) self) (if (and (contn-transparent? self) (not (eq? self #*barrier-node))) (number-of-args-to-pop (node-enclosing-contour self)) 0)) (add-method (nguys-to-pop (ast-node enclosing-contour) self) (number-of-args-to-pop enclosing-contour)) (add-method (pop-args (ast-node enclosing-contour) self n-to-blt) (blt-stack n-to-blt (number-of-args-to-pop enclosing-contour))) (add-method (pop-args-before-labels-jump (ast-node enclosing-contour) self n-to-blt stop-contour) (bind ((#*barrier-node stop-contour)) (blt-stack n-to-blt (number-of-args-to-pop enclosing-contour))))) (add-method (primitive-continuation (ast-node) self cont) (cond ((eq? cont 'next) '()) ((eq? cont 'tail) (append (pop-args self 1) (list '(return)))) (else `((branch ,cont))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; generate the code for variable references ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-instance compute-offset operation) (define-instance gen-access-code operation) (add-method (compute-offset (ast-variable-node var-type name) self the-map) (or (position-in-list name the-map) (error "CodeGen: can't find variable ~S in ~S map ~S" name var-type the-map))) ;;; Hey, Kevin, isn't the following routine a little inconsistent in the way ;;; it handles globals? I don't understand. ;;; Is it true that this is always called in LOAD mode now, since %SET has ;;; been flushed? (add-method (gen-access-code (ast-variable-node var-type name source-contour) self cont store?) (append (cond ((eq? var-type 'stack) `((,(if store? 'store-stk 'load-stk) ,(compute-offset self (node-stack-map self)) ,name))) ((eq? var-type 'evar) `((,(if store? 'store-env 'load-env) ;; Note the extra offset of 2 here: ,(+ 2 (compute-offset self (contn-envlist source-contour))) ,name))) ((eq? var-type 'ivar) `((,(if store? 'store-bp 'load-bp) ,(compute-offset self (methn-ivarmap source-contour)) ,name))) ((eq? var-type 'global) `((load-glo ,name))) (else (error "gen-access: Error in var-type for ~S" (list var-type name)))) (primitive-continuation self cont))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; the code generator ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; The gen-code operation takes two arguments, an ast node and a continuation, ; which may be one of three things: the symbol TAIL, the symbol NEXT, ; or a label, which can be any other symbol. (define-instance top-level-gen-code operation) (add-method (top-level-gen-code (ast-node) self) (block0 (list 'code '() (peephole-optimize (block0 (gen-code self 'tail) (print-sp 'code)))) (print-sp 'done))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-instance gen-code operation) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;Definitions for the primitive forms (with-operations (nargs-prologue) (add-method (nargs-prologue (ast-method-node arglist rest-name) self) (if rest-name (let ((real-nargs (length (cdr arglist)))) (if (= 0 real-nargs) ;; The (POP 1) is here due to the new operation nargs discipline. (list `(pop 1) `(load-reg nargs)) (list `(check-nargs-gte ,real-nargs) `(load-imm ,real-nargs) `(load-reg nargs) `(subtract)))) (list `(check-nargs ,(length arglist))))) (add-method (gen-code (ast-method-node ivarmap status body arglist) self cont) (cond ((eq? status 'code) (append (list `(load-code (code ,ivarmap ,(append (nargs-prologue self) (gen-code body 'tail))))) (primitive-continuation self cont))) ((eq? status 'inline) (gen-code body cont)) (else `((,status is the wrong kind of method)))))) (labels (((how-to-load value name) (if name `(load-imm ,value ,name) `(load-imm ,value)))) (add-method (gen-code (ast-constant-node value name origin) self cont) (cond ((or (not #*compiling-a-file?) (eq? value #t) (null? value) (number? value) (symbol? value) (string? value) (char? value) (pair? value)) (list* (how-to-load value name) (primitive-continuation self cont))) ((eq? origin nichevo) (warning "~S should not be an inline constant.~%" value) (list* (how-to-load value name) (primitive-continuation self cont))) (else (gen-code origin cont))))) (add-method (gen-code (ast-variable-node) self cont) (gen-access-code self cont #f)) (add-method (gen-code (ast-set-node variable expression) self cont) (append (gen-code expression 'next) (gen-access-code variable cont #t))) (let ((gen-makloc-code (make operation))) (add-method (gen-makloc-code (ast-variable-node var-type name source-contour) self cont) (append (cond ((memq var-type '(stack evar global)) (error "CodeGen: the makloc node around ~S should have been removed by fold-contents" (list var-type name))) ((eq? var-type 'ivar) (list `(make-bp-loc ,(compute-offset self (methn-ivarmap source-contour)) ,name))) (else (error "Makloc: Error in var-type for ~S" (list var-type name)))) (primitive-continuation self cont))) (add-method (gen-code (ast-make-locative-node variable) self cont) (gen-makloc-code variable cont))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;Definitions for the composite forms. (add-method (gen-code (ast-block-node body) self cont) (if (< (length body) 1) (error "CodeGen: Empty body in block.") (iterate step ((in body)(out '())) (if (= 1 (length in)) (append out (gen-code (car in) cont)) (step (cdr in) (splice (list out (gen-code (car in) 'next) (list '(pop 1))))))))) (add-method (gen-code (ast-if-node predicate consequent alternate) self cont) (let ((alt-label (gensym "ELSE")) (arm1-cont (if (eq? cont 'next) (gensym "ENDIF") cont))) (splice (list (gen-code predicate 'next) `((branch-nil ,alt-label)) (gen-code consequent arm1-cont) (list `(label ,alt-label)) (gen-code alternate cont) (if (eq? cont 'next) (list `(label ,arm1-cont)) '()))))) (add-method (gen-code (ast-labels-node gensymlist lambdalist body) self cont) (let ((end-cont (if (eq? cont 'next) (gensym "ENDLABELS") cont))) (bind ((#*barrier-node (if (eq? cont 'tail) #*barrier-node self))) (splice (list (if (eq? end-cont 'tail) '() (list `(push-cxt ,end-cont))) (gen-code body 'tail) (iterate step ((gen gensymlist)(lam lambdalist)(out '())) (if (null? gen) out (step (cdr gen) (cdr lam) (append (cons `(label ,(car gen)) (gen-code (car lam) 'tail)) out)))) (if (eq? cont 'next) (list `(label ,end-cont)) '())))))) ;; see catch.oak for an explanation of the following method. (add-method (gen-code (ast-catch-node expression) self cont) (let ((end-cont (if (eq? cont 'next) (gensym "ENDCATCH") cont))) (let* ((body-code (bind ((#*barrier-node (if (eq? cont 'tail) #*barrier-node (combn-op expression))) ;the LET lambda (#*filltag-offset (1+ (if (eq? cont 'tail) (nguys-to-pop self) 0)))) (gen-code expression 'tail)))) (splice (list (if (eq? end-cont 'tail) '() (list `(push-cxt ,end-cont))) body-code (if (eq? cont 'next) (list `(label ,end-cont)) '())))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;Definitions for compiling combinations (with-operations (open-code label-code inline-code regular-code combo-op get-jump-info) (add-method (combo-op (ast-combination-node op rest-name) self) (cond ((not (eq? rest-name nichevo)) regular-code) ((and (is-a? op ast-constant-node) (is-a? (constn-value op) open-coded-mixin)) open-code) ((and (is-a? op ast-variable-node) (eq? 'label (varn-var-type op))) label-code) ((and (is-a? op ast-method-node) (eq? 'inline (methn-status op))) inline-code) ((is-a? op ast-method-node) (error "CodeGen: ~S is the wrong status for a car position method." (methn-status op))) (else regular-code))) (add-method (gen-code (ast-combination-node) self cont) ((combo-op self) self cont)) (add-method (get-jump-info (ast-labels-node labellist lambdalist gensymlist) self name) (let* ((the-lambda (rib-lookup labellist lambdalist name)) (the-target (rib-lookup labellist gensymlist name)) (nargs-required (length (methn-arglist the-lambda)))) (cons the-target nargs-required))) (add-method (label-code (ast-combination-node op args) self cont) (let* ((name (varn-name op)) (source-contour (varn-source-contour op)) (jump-info (get-jump-info source-contour name)) (the-target (car jump-info)) (nargs-required (cdr jump-info))) (if (eq? cont 'tail) (if (= (length args) nargs-required) `(,@(splice (map (lambda (x) (gen-code x 'next)) (reverse args))) ,@(pop-args-before-labels-jump self (length args) source-contour) (branch ,the-target)) (error "CodeGen: Wrong number of arguments to operation ~S" name)) (error "Compiler error: branch to ~S not tail recursive" the-target)))) (add-method (open-code (ast-combination-node op args) self cont) (let* ((n-args (length args)) (opval (constn-value op)) (desired-n-args (get-n-arguments opval)) (open-coder (copy (get-byte-code-list opval))) (bytes (if (list? open-coder) open-coder (open-coder n-args)))) (if (or (null? desired-n-args) (= n-args desired-n-args)) `(,@(splice (map (lambda (x) (gen-code x 'next)) (if (is-a? opval backwards-args-mixin) args (reverse args)))) ,@(if (eq? cont 'tail) (pop-args self n-args) '()) ,@(copy bytes) ,@(cond ((eq? cont 'next) '()) ((eq? cont 'tail) (list '(return))) (else `((branch ,cont))))) (error "CodeGen: Wrong number of arguments to operation ~S" opval)))) (add-method (inline-code (ast-combination-node op args) self cont) (let ((label? (not (memq cont '(next tail))))) (if (= (length args) (length (methn-arglist op))) (splice (list (splice (map (lambda (x) (gen-code x 'next)) (reverse args))) (gen-code op (if label? 'next cont)) (if (eq? cont 'tail) '() (blt-stack 1 (length args))) (if label? `((branch ,cont)) '()))) (error "CodeGen: Wrong number of arguments to inline lambda")))) (add-method (regular-code (ast-combination-node op args rest-name) self cont) (let* ((nmyargs (length args)) (totalmyargs (+ 1 nmyargs))) (splice (list (splice (map (lambda (x) (gen-code x 'next)) (reverse args))) (gen-code op 'next) (if (eq? rest-name nichevo) `((store-nargs ,nmyargs)) (splice (list (gen-code rest-name 'next) (if (= 0 nmyargs) '() (list `(load-imm ,nmyargs) '(plus))) (list `(store-reg nargs) `(pop 1))))) (if (eq? cont 'tail) (pop-args self totalmyargs) '()) (cond ((eq? cont 'tail) `((funcall-tail))) ((eq? cont 'next) `((funcall-cxt))) (else `((funcall-cxt-br ,cont))))))))) oaklisp-1.3.3.orig/src/world/consume.oak0000664000175000000620000001067107725515165017166 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter (labels (((consume1 val arg . args) (if (= 0 (rest-length args)) val (consume1 val . args)))) (define (consume-args val . args) (if (= 0 (rest-length args)) val (consume1 val . args)))) (labels (((helper1 op list-head prev-pair a) (set! (cdr prev-pair) (list a)) (op (cdr list-head))) ((helper2 op list-head prev-pair a b) (set! (cdr prev-pair) (list a b)) (op (cdr list-head))) ((helper3 op list-head prev-pair a b c) (set! (cdr prev-pair) (list a b c)) (op (cdr list-head))) ((helper4 op list-head prev-pair a b c d) (set! (cdr prev-pair) (list a b c d)) (op (cdr list-head))) ((helper5 op list-head prev-pair a b c d e) (set! (cdr prev-pair) (list a b c d e)) (op (cdr list-head))) ((helper6 op list-head prev-pair a b c d e f) (set! (cdr prev-pair) (list a b c d e f)) (op (cdr list-head))) ((helper7 op list-head prev-pair a b c d e f g) (set! (cdr prev-pair) (list a b c d e f g)) (op (cdr list-head))) ((helper8+ op list-head prev-pair a b c d e f g h . rest) (let ((new-last-pair (cons h '()))) (set! (cdr prev-pair) (cons a (cons b (cons c (cons d (cons e (cons f (cons g new-last-pair)))))))) (cond ((> (rest-length rest) 7) (helper8+ op list-head new-last-pair . rest)) ((< (rest-length rest) 4) (cond ((zero? (rest-length rest)) (op (cdr list-head))) ((= (rest-length rest) 1) (helper1 op list-head new-last-pair . rest)) ((= (rest-length rest) 2) (helper2 op list-head new-last-pair . rest)) (else (helper3 op list-head new-last-pair . rest)))) (else (cond ((= (rest-length rest) 4) (helper4 op list-head new-last-pair . rest)) ((= (rest-length rest) 5) (helper5 op list-head new-last-pair . rest)) ((= (rest-length rest) 6) (helper6 op list-head new-last-pair . rest)) (else (helper7 op list-head new-last-pair . rest)))))))) (define (listify-args op . rest) (let ((list-head (cons '() '()))) (cond ((< (rest-length rest) 4) (cond ((= (rest-length rest) 1) (helper1 op list-head list-head . rest)) ((= (rest-length rest) 2) (helper2 op list-head list-head . rest)) ((= (rest-length rest) 3) (helper3 op list-head list-head . rest)) ((zero? (rest-length rest)) (op '())))) ((< (rest-length rest) 8) (cond ((= (rest-length rest) 4) (helper4 op list-head list-head . rest)) ((= (rest-length rest) 5) (helper5 op list-head list-head . rest)) ((= (rest-length rest) 6) (helper6 op list-head list-head . rest)) (else (helper7 op list-head list-head . rest)))) (else (helper8+ op list-head list-head . rest))))) ) #| (labels (((listify-args-aux listify-argsofar op guy . rest) (if (zero? (rest-length rest)) (iterate inline-reverse! ((old (cons guy listify-argsofar)) (new nil)) (cond ((null? old) (op new)) (else (let ((o (cdr old))) (set! (cdr old) new) (inline-reverse! o old))))) (listify-args-aux (cons guy listify-argsofar) op . rest)))) (define (listify-args op . rest) (cond ((zero? (rest-length rest)) (op '())) (else (listify-args-aux '() op . rest))))) |# (labels (((bla-aux bla-so-far op guy . rest) (if (zero? (rest-length rest)) (op (cons guy bla-so-far)) (bla-aux (cons guy bla-so-far) op . rest)))) (define (backwards-listify-args op . rest) (cond ((zero? (rest-length rest)) (op '())) (else (bla-aux '() op . rest))))) oaklisp-1.3.3.orig/src/world/patch-locales.oak0000664000175000000620000000215307725515165020230 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter (define (patch-locales) (iterate go ((varloc %%varloc)(symloc %%symloc)(count 0)) (print-noise #\&) (when (< count %%nvars) (set! (variable-here? system-locale (%set-tag symloc %pointer-tag)) varloc) (go (%increment-locative varloc 1) (%increment-locative symloc %%symsize) (+ 1 count))))) (patch-locales) oaklisp-1.3.3.orig/src/world/booted.oak0000664000175000000620000000334607725515165016772 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter ;;; We're up enough now to attempt a read-eval-print loop upon reboot. (define (%get-an-ivar t o v) (contents (car (%locate-ivars t o (list v))))) (let* ((reboot-lambda (lambda () (set! ((%register 'nil)) (the-runtime nil)) (set! ((%register 't)) (the-runtime t)) (set! ((%register 'cons-type)) (the-runtime cons-pair)) (set! ((%register 'object-type)) (the-runtime object)) (set! ((%register 'fixnum-type)) (the-runtime fixnum)) (set! ((%register 'loc-type)) (the-runtime locative)) (set! ((%register 'env-type)) (the-runtime %closed-environment)) (set! ((%register 'segment-type)) (the-runtime stack-segment)) (set! ((%register 'method-type)) (the-runtime %method)) (set! ((%register 'operation-type)) (the-runtime operation)) (warm-boot) ;; (format t "warm boot actions ~S~%" warm-boot-actions) (top-level))) (reboot-method (%get-an-ivar operation reboot-lambda 'lambda?))) (set! ((%register 'boot-code)) reboot-method)) oaklisp-1.3.3.orig/src/world/cold-booting.oak0000664000175000000620000000213507725515165020071 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Barak A. Pearlmutter and Kevin J. Lang (%write-char #\C) (%write-char #\o) (%write-char #\l) (%write-char #\d) (%write-char #\space) (%write-char #\b) (%write-char #\o) (%write-char #\o) (%write-char #\t) (%write-char #\i) (%write-char #\n) (%write-char #\g) (%write-char #\space) (%write-char #\.) (%write-char #\.) (%write-char #\.) (%write-char #\newline) ;;; eof oaklisp-1.3.3.orig/src/world/tag-trap.oak0000664000175000000620000001336007725515165017232 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;;; Copyright (C) 1987 Barak A. Pearlmutter & Kevin J. Lang ;;; Set up the tables needed by the tag trap mechanism. (define %arged-instructions 35) ;;; was 67 before multithreading instructions. Would be 70+ now ;;; except for ALARM which is at 127. TO DO: move it down. (define %argless-instructions 128) (define-instance %argless-tag-trap-table simple-vector %argless-instructions) (define-instance %arged-tag-trap-table simple-vector %arged-instructions) (let ((aux (lambda (args) (destructure (i . args) args (error "unexpected trap from argless instruction ~D, args ~S." i args))))) (dotimes (i %argless-instructions) (set! (nth %argless-tag-trap-table i) (lambda ( . args) (listify-args aux i . args))))) (let ((aux (lambda (args) (destructure (i arg . args) args (error "unexpected trap from arged instruction ~D ~D, args ~S." i arg args))))) (dotimes (i %arged-instructions) (set! (nth %arged-tag-trap-table i) (lambda (arg . args) (listify-args aux i arg . args))))) ;;; And these are the things that can go wrong here: (set! (nth %argless-tag-trap-table 1) plus/2) (set! (nth %argless-tag-trap-table 2) minus) ;(set! (nth %argless-tag-trap-table 3) eq?) ;(set! (nth %argless-tag-trap-table 4) not) (set! (nth %argless-tag-trap-table 5) times/2) (set! (nth %argless-tag-trap-table 7) quotient) (set! (nth %argless-tag-trap-table 8) zero?) (set! (nth %argless-tag-trap-table 11) %crunch) (set! (nth %argless-tag-trap-table 12) %read-char) ;These are for noise at (set! (nth %argless-tag-trap-table 13) %write-char); cold boot time. (set! (nth %argless-tag-trap-table 14) contents) (set! (nth %argless-tag-trap-table 15) (setter contents)) ;(set! (nth %argless-tag-trap-table 16) get-type) (set! (nth %argless-tag-trap-table 18) negative?) (set! (nth %argless-tag-trap-table 19) modulo) (set! (nth %argless-tag-trap-table 20) ash-left) (set! (nth %argless-tag-trap-table 21) rot-left) ;(set! (nth %argless-tag-trap-table 22) (setter %load-bp-i)) ;(set! (nth %argless-tag-trap-table 23) %load-bp-i) ;(set! (nth %argless-tag-trap-table 25) %allocate) (set! (nth %argless-tag-trap-table 26) %assq) ;(set! (nth %argless-tag-trap-table 28) %peek) ;(set! (nth %argless-tag-trap-table 29) (setter %peek)) (set! (nth %argless-tag-trap-table 31) subtract/2) (set! (nth %argless-tag-trap-table 32) =) (set! (nth %argless-tag-trap-table 33) <) (set! (nth %argless-tag-trap-table 34) bit-not) (set! (nth %argless-tag-trap-table 39) contents) (set! (nth %argless-tag-trap-table 40) car) (set! (nth %argless-tag-trap-table 41) cdr) (set! (nth %argless-tag-trap-table 42) (setter car)) (set! (nth %argless-tag-trap-table 43) (setter cdr)) (set! (nth %argless-tag-trap-table 44) (locater car)) (set! (nth %argless-tag-trap-table 45) (locater cdr)) (set! (nth %argless-tag-trap-table 48) throw) (set! (nth %argless-tag-trap-table 50) object-unhash) ;(set! (nth %argless-tag-trap-table 51) %gc) ;(set! (nth %argless-tag-trap-table 52) big-endian?) (set! (nth %argless-tag-trap-table 53) %varlen-allocate) (set! (nth %argless-tag-trap-table 54) %increment-locative) (set! (nth %argless-tag-trap-table 55) %fill-continuation) (set! (nth %argless-tag-trap-table 56) %continue) ;(set! (nth %argless-tag-trap-table 57) reverse-cons) ;(set! (nth %argless-tag-trap-table 58) most-negative-fixnum?) (set! (nth %argless-tag-trap-table 59) fx-plus) (set! (nth %argless-tag-trap-table 60) fx-times) ;(set! (nth %argless-tag-trap-table 61) get-time) (set! (nth %argless-tag-trap-table 62) remainder) (set! (nth %argless-tag-trap-table 63) quotientm) ;(set! (nth %argless-tag-trap-table 64) %full-gc) ;(set! (nth %argless-tag-trap-table 127) alarm) ;;; By writing things this way we prevent open coding: (define (trap-bit-op arg x y) (let ((op (cond ((= arg #b0001) bit-and) ((= arg #b1110) bit-nand) ((= arg #b0111) bit-or) ((= arg #b1000) bit-nor) ((= arg #b0110) bit-xor) ((= arg #b1001) bit-equiv) ((= arg #b0100) bit-andca) (else (error "Illegal instruction (BIT-OP #b~B) with args ~S, ~S.~%" arg x y))))) (op x y))) (set! (nth %arged-tag-trap-table 2) trap-bit-op) ;;; These aren't defined yet, so this stuff gets done later. ;(set! (nth %arged-tag-trap-table 21) no-handler-for-operation) ;(set! (nth %arged-tag-trap-table 22) no-handler-for-operation) ;(set! (nth %arged-tag-trap-table 24) incorrect-nargs) ;(set! (nth %arged-tag-trap-table 25) incorrect-nargs-gte) ;(set! (nth %arged-tag-trap-table 26) (setter %slot)) ;(set! (nth %arged-tag-trap-table 27) %slot) ;(set! (nth %arged-tag-trap-table 30) (locater %slot)) ;(set! (nth %arged-tag-trap-table 32) %filltag) ;;; As above with no-handler-for-operation, this gets done later: ;(set! (nth %arged-tag-trap-table 33) no-^super-handler) ;(set! (nth %arged-tag-trap-table 34) no-^super-handler) ;;; Plug into the emulator: (define (setup-tag-traps) (set! ((%register 'argless-tag-trap-table)) %argless-tag-trap-table) (set! ((%register 'arged-tag-trap-table)) %arged-tag-trap-table) nil) (setup-tag-traps) ;;; eof oaklisp-1.3.3.orig/src/world/describe.oak0000664000175000000620000000417207725515165017274 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Barak A. Pearlmutter&Kevin J. Lang ;;; A simple describe facility. ;;; You can define your own DESCRIBE methods to shadow this one. (define-instance describe operation) (add-method (describe (object) x) (deep-describe x)) (add-method (describe (fixnum) x) (if (negative? x) (^super object describe x) (let ((o (object-unhash x))) (if o (deep-describe o) (^super object describe x))))) (let ((describe-frame (make operation))) (add-method (describe-frame (type ivar-list) self frame obj) (cond ((eq? self variable-length-mixin) (format #t "~& from ~A:~%" self) (dotimes (i (- ((%slot 1) obj) ((%slot 1) (get-type obj)))) (format #t " ~D : ~S~%" i (%vref obj i)))) ((not (null? ivar-list)) (format #t "~& from ~A:~%" self) (iterate aux ((vars ivar-list)(fp frame)) (when vars (format #t " ~A : ~S~%" (car vars) (contents fp)) (aux (cdr vars) (%increment-locative fp 1))))))) (define (deep-describe x) (bind ((#*forcible-print-magic #f)) (let ((ty (get-type x))) (bind ((#*fancy-references #t)) (format #t "~&~S is of type ~S.~%" x ty)) (when (= (%tag x) %pointer-tag) (let ((loc-x (%set-tag x %locative-tag))) (iterate aux ((alist (get-bp-alist ty))) (when alist (describe-frame (caar alist) (%increment-locative loc-x (cdar alist)) x) (aux (cdr alist)))))))) x) ) ;;; eof oaklisp-1.3.3.orig/src/world/top-level.oak0000664000175000000620000001012607725515165017417 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Kevin J. Lang & Barak A. Pearlmutter ;;; Read eval print loop for Oaklisp. (define (read-eval-print-loop) (format #t "~&Oaklisp evaluation loop.~%") (bind ((#*print-length 7) (#*print-level 3) (#*print-escape #t) ;; Current input (#*- #f) ;; Previous inputs: (#*+ #f) (#*++ #f) (#*+++ #f) ;; Previous macro expanded inputs: (#*? #f) (#*?? #f) (#*??? #f) ;; Previous outputs: (#** #f) (#*** #f) (#**** #f)) (let ((message (if (zero? #*debug-level) "Return to top level." (format #f "Return to debugger level ~D." #*debug-level)))) (error-restart message () (show-handlers) (let ((out-of-here (and (not (zero? #*debug-level)) #*up-a-debug-level))) (iterate aux () (native-catch uptag (bind ((#*up-a-debug-level uptag)) (dotimes (i (+ #*debug-level 1)) (write-char standard-output #\>)) (write-char standard-output #\space) (flush standard-output) (set! #*+++ #*++) (set! #*++ #*+) (set! #*+ #*-) (let ((r (bind-error-handler (read-error (lambda (x) (format standard-error "~&Malformed user input.~%") ;; Flush typeahead here? (invoke-debugger x))) (read standard-input)))) (clear-backspace-buffer standard-input) (cond ((eq? r the-eof-token) (cond ((not (interactive? standard-input)) (format #t "~&Exiting: EOF on non-interactive control stream.~%") (flush standard-output) (exit)) ((zero? #*debug-level) (format #t "~&Type (exit) to leave Oaklisp.~%") (aux)) (else (write-char standard-output #\newline) (throw out-of-here #f)))) (else (set! #*- r) (let ((m (bind-error-handler (general-error (lambda (x) (format standard-error "~&Unable to macroexpand ~S.~%" r) (invoke-debugger x))) (let ; error-restart ; "Try to macroexpand it again (args: expr, locale)." ((exp r) (loc #*current-locale)) (expand-groveling loc exp))))) (set! #*??? #*??) (set! #*?? #*?) (set! #*? m) (let ((v (bind-error-handler (general-error invoke-debugger) (subeval m #*current-locale)))) (set! #**** #***) (set! #*** #**) (set! #** v) (bind-error-handler (general-error (lambda (x) (format standard-error "~&Unable to print result.~%") (invoke-debugger x))) (print v standard-output)) (write-char standard-output #\newline)))))))) (aux))))))) (set! top-level (lambda () (format #t "~&Welcome to Oaklisp 1.3.3~%") (read-eval-print-loop))) (define (eval form locale) (subeval (expand-groveling locale form) locale)) (define (subeval form locale) (#*top-level-evaluator form locale)) (set! #*top-level-evaluator interpreter-eval) (define (hybrid-eval form locale) ((if (contains-add-method? form) compiler-eval interpreter-eval) form locale)) (let ((warned-yet? #f)) (define (compiler-eval form locale) (unless warned-yet? (warning "compiler isn't loaded, using interpreter.") (set! warned-yet? #t)) (interpreter-eval form locale))) (define (contains-add-method? form) (and (pair? form) (not (eq? 'quote (car form))) (or (eq? '%add-method (car form)) (contains-add-method? (car form)) ;close enough for (contains-add-method? (cdr form))))) ;rock and roll. ;;; eof oaklisp-1.3.3.orig/src/world/error2.oak0000664000175000000620000000562007725515165016726 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;;; This is a stopgap error handling system. It defines the following ;;; macros: ;;; ;;; (error-return "Specify a value to be returned from this construct." ;;; . body) ;;; ;;; (error-restart "Specify some new values for these variables." ;;; ((var1 val1)(var2 val2)) ;;; . body) ;;; ;;; The implementation involves making catch tags and stashing them in a ;;; data structure bound to a fluid variable. (set! #*restart-handlers '()) (define-syntax (error-return message . body) (let ((tag (genvar))) `(native-catch ,tag (bind ((#*restart-handlers (cons (list ,message (lambda (x) (throw ,tag (and x (car x)))) 1) #*restart-handlers))) ,@body)))) ;;; This utility function is used below for rebinding only the supplied vars. (define (subst-vals-in old new) (cond ((null? new) old) (else (cons (car new) (subst-vals-in (cdr old) (cdr new)))))) (define-syntax (error-restart message variables . body) (let ((aux (genvar)) (tag (genvar)) (tag0 (genvar)) (messvar (genvar)) (temps (map (lambda (x) (genvar)) variables))) `(native-catch ,tag0 (let ((,messvar ,message)) (iterate ,aux ,variables (destructure ,temps (subst-vals-in (list ,@(map car variables)) (catch ,tag (throw ,tag0 (bind ((#*restart-handlers (cons (list ,messvar ,tag ,(length variables)) #*restart-handlers))) ,@body)))) (,aux ,@temps))))))) (define (show-handlers) (format #t "~& Active handlers:~%") (iterate aux ((i 0)(l (reverse #*restart-handlers))) (when (not (null? l)) (format #t " ~D: ~A~%" i (caar l)) (aux (+ i 1) (cdr l))))) (define (ret n . args) (listify-args (lambda (args) (let* ((handlers #*restart-handlers) (nhandlers (length handlers)) (handler (nth handlers (- nhandlers (1+ n))))) (destructure (message tag arg-count) handler (format standard-error "~&Invoking handler \"~A\"~%" message) (cond ((< arg-count (length args)) (error "Handler \"~A\" was passed ~D args but takes only ~D.~%" message (length args) arg-count)) (else (tag args)))))) . args)) ;;; eof oaklisp-1.3.3.orig/src/world/coerce.oak0000664000175000000620000000272307725515165016754 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter. ;;; Define a kind of type that can be coerced to. Such types have a ;;; coercer operation, which can be applied to an instance of some other ;;; type in order to coerce it to this type. For example, to coerce a ;;; number X to floating point, write ((COERCER FLOAT) X) or, with read ;;; macros, (#^FLOAT X). ;;; This definition goes in "KERNEL" so primitive types can be coercable. ;(define-instance coercable-type type '(co-op) (list type)) (define-constant-instance coercer (mix-types oc-mixer (list foldable-mixin settable-operation))) (add-method (coercer (coercable-type co-op) self) co-op) (add-method ((setter coercer) (coercable-type co-op) self new-op) (set! co-op new-op)) ;;; eof oaklisp-1.3.3.orig/src/world/alarm.oak0000664000175000000620000000324007725515165016603 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;; ;; ;; Handles alarm traps which are arbitrarily generated by the bytecode ;; emulator. ;; #| (define (alarm n) (%disable-alarms) (format #t "*Bing*") (set! ((%register 'nargs)) n) (%reset-alarm-counter) (%enable-alarms) (%return)) |# (define alarm (add-method ((make operation) n) (pause) (set! ((%register 'nargs)) n) (%return))) ;;; avoid forward reference in tag-trap.oak (set! (nth %argless-tag-trap-table 127) alarm) ;; ;; Define atomic functions (op-codes) for turning alarms on and off. ;; (define-constant %enable-alarms (add-method ((make-open-coded-operation '((enable-alarms)) 0 1) (object)) (%enable-alarms))) (define-constant %disable-alarms (add-method ((make-open-coded-operation '((disable-alarms)) 0 1) (object)) (%disable-alarms))) (define-constant %reset-alarm-counter (add-method ((make-open-coded-operation '((reset-alarm-counter)) 0 1) (object)) (%reset-alarm-counter))) oaklisp-1.3.3.orig/src/world/scheme-macros.oak0000664000175000000620000000535107725515165020242 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang ;;; The following macro definitions are different from those in ;;; system-locale in a non-upward-compatible way. These definitions ;;; should NOT be loaded into system-locale. They may be compiled ;;; there, though. ;;; Because all forms that take implicit bodies ultimately put a BLOCK ;;; around these bodies, the above also makes ADD-METHOD, and hence ;;; LAMBDA, as well as stuff like COND clause bodies, get the horrible ;;; MIT Scheme define-capturing semantics. (define-syntax (block . body) `(mit-block . ,body)) ;;; That committee must have Algol on the brain. (define-syntax (begin . body) `(block . ,body)) ;;; Here, we make the dotted arglist syntax do the R3RS thing, getting ;;; bound to a list of things. We do this by hacking ADD-METHOD to ;;; wrap a LABELS if appropriate. (define-syntax (add-method (op . stuff) . body) (cond ((improper-list? stuff) => (lambda (improper-part) (let ((proper-part (make-proper stuff)) (auxvar (genvar))) (cond ((and (not (null? proper-part)) (list? (car proper-part)) (not (null? (cdr (car proper-part))))) ;; There are ivars, have to close over them. `(native-add-method (,op ,(car proper-part) . ,improper-part) (let ((,auxvar (lambda (,improper-part) (destructure ,(cdr stuff) ,improper-part ,@body)))) (listify-args ,auxvar . ,improper-part)))) (else ;; No ivars, make external lambda `(let ((,auxvar (lambda (,improper-part) (destructure ,(if (and (not (null? proper-part)) (list? (car proper-part))) ;; clause (cdr stuff) stuff) ,improper-part ,@body)))) (native-add-method (,op ,@(if (and (not (null? proper-part)) (list? (car proper-part))) (list (car proper-part)) (list)) . ,improper-part) (listify-args ,auxvar . ,improper-part)))))))) (else `(native-add-method (,op . ,stuff) . ,body)))) ;;; eof oaklisp-1.3.3.orig/src/world/conses.oak0000664000175000000620000001422607725515165017007 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Barak A. Pearlmutter & Kevin J. Lang (local-syntax (define-cxr cxr op-list) (labels ((nestify (lambda (l a) (if (null? l) a (list (car l) (nestify (cdr l) a)))))) (let ((nestified (nestify op-list 'x))) `(block (define-constant ,cxr (make-cxr ',op-list)) (add-method (,cxr (pair) x) ,nestified) (add-method ((setter ,cxr) (pair) x y) (set! ,nestified y)) (add-method ((locater ,cxr) (pair) x) (make-locative ,nestified)))))) (let* ((opencodtypes (list open-coded-mixin operation)) (opencodop (mix-types oc-mixer opencodtypes)) (foldableopencodop (mix-types oc-mixer (cons foldable-mixin opencodtypes)))) (define (make-open-coded-operation code in-count out-count) (make opencodop code in-count out-count)) (define (make-foldable-open-coded-operation code in-count out-count) (make foldableopencodop code in-count out-count)) (define (make-fancy-open-coded-operation other-types code in-count out-count) (make (mix-types oc-mixer (%append other-types opencodtypes)) code in-count out-count))) ;; note: %append is used here because append isn't defined until later ;; Cons-pair is initialized properly in the kernel files. (define-constant cons (add-method ((make-open-coded-operation '((cons)) 2 1) (object) x y) (cons x y))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (labels ((map-list (lambda (x) (if (null? x) x (cons (list (car x)) (map-list (cdr x)))))) (reverse-aux (lambda (x y) (if (null? x) y (reverse-aux (cdr x) (cons (car x) y))))) (setify (lambda (x) (cond ((eq? x 'car) 'set-car) ((eq? x 'cdr) 'set-cdr) (else (error "~A isn't CAR or CDR." x))))) (locify (lambda (x) (cond ((eq? x 'car) 'locate-car) ((eq? x 'cdr) 'locate-cdr) (else (error "~A isn't CAR or CDR." x))))) (make-cxr (lambda (sequence) (let ((cxr (make (mix-types oc-mixer (list open-coded-mixin locatable-operation)) (reverse-aux (map-list sequence) '()) 1 1))) (set! (setter cxr) (make (mix-types oc-mixer (list open-coded-mixin operation)) (reverse-aux (map-list (cons (setify (car sequence)) (cdr sequence))) '()) 2 1)) (set! (locater cxr) (make (mix-types oc-mixer (list open-coded-mixin operation)) (reverse-aux (map-list (cons (locify (car sequence)) (cdr sequence))) '()) 1 1)) cxr)))) (define-constant car (make-cxr '(car))) (add-method (car (cons-pair the-car) self) the-car) (add-method ((setter car) (cons-pair the-car) self y) (set! the-car y)) (add-method ((locater car) (cons-pair the-car) self) (make-locative the-car)) (define-constant cdr (make-cxr '(cdr))) (add-method (cdr (cons-pair the-cdr) self) the-cdr) (add-method ((setter cdr) (cons-pair the-cdr) self y) (set! the-cdr y)) (add-method ((locater cdr) (cons-pair the-cdr) self) (make-locative the-cdr)) (define-cxr caar (car car)) (define-cxr cadr (car cdr)) (define-cxr cdar (cdr car)) (define-cxr cddr (cdr cdr)) (define-cxr caaar (car car car)) (define-cxr caadr (car car cdr)) (define-cxr cadar (car cdr car)) (define-cxr caddr (car cdr cdr)) (define-cxr cdaar (cdr car car)) (define-cxr cdadr (cdr car cdr)) (define-cxr cddar (cdr cdr car)) (define-cxr cdddr (cdr cdr cdr)) (define-cxr caaaar (car car car car)) (define-cxr caaadr (car car car cdr)) (define-cxr caadar (car car cdr car)) (define-cxr caaddr (car car cdr cdr)) (define-cxr cadaar (car cdr car car)) (define-cxr cadadr (car cdr car cdr)) (define-cxr caddar (car cdr cdr car)) (define-cxr cadddr (car cdr cdr cdr)) (define-cxr cdaaar (cdr car car car)) (define-cxr cdaadr (cdr car car cdr)) (define-cxr cdadar (cdr car cdr car)) (define-cxr cdaddr (cdr car cdr cdr)) (define-cxr cddaar (cdr cdr car car)) (define-cxr cddadr (cdr cdr car cdr)) (define-cxr cdddar (cdr cdr cdr car)) (define-cxr cddddr (cdr cdr cdr cdr)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define first (lambda (x) (nth x 0))) (define second (lambda (x) (nth x 1))) (define third (lambda (x) (nth x 2))) (define fourth (lambda (x) (nth x 3))) (define fifth (lambda (x) (nth x 4))) (define sixth (lambda (x) (nth x 5))) (define seventh (lambda (x) (nth x 6))) (define eighth (lambda (x) (nth x 7))) (define ninth (lambda (x) (nth x 8))) (define tenth (lambda (x) (nth x 9))) (add-method (length (list-type) inlist) (labels ( ((loop7 remaining count) (if (null? remaining) (+ 7 count) (loop0 (cdr remaining) (+ 8 count)))) ((loop6 remaining count) (if (null? remaining) (+ 6 count) (loop7 (cdr remaining) count))) ((loop5 remaining count) (if (null? remaining) (+ 5 count) (loop6 (cdr remaining) count))) ((loop4 remaining count) (if (null? remaining) (+ 4 count) (loop5 (cdr remaining) count))) ((loop3 remaining count) (if (null? remaining) (+ 3 count) (loop4 (cdr remaining) count))) ((loop2 remaining count) (if (null? remaining) (+ 2 count) (loop3 (cdr remaining) count))) ((loop1 remaining count) (if (null? remaining) (+ 1 count) (loop2 (cdr remaining) count))) ((loop0 remaining count) (if (null? remaining) count (loop1 (cdr remaining) count))) ) (loop0 inlist 0))) #| (add-method (length (list-type) l) (iterate aux ((l l)(n 0)) (if l (aux (cdr l) (+ n 1)) n))) |# ;;; eof oaklisp-1.3.3.orig/src/world/read-token.oak0000664000175000000620000002201207725515165017536 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1992 Kevin J. Lang & Barak A. Pearlmutter ;;; Stuff to do token reading and parsing. ;;; This seems as nice a place as any: (set! #*input-base 10) ;;; Read tokens: NFA. Recognizes number with either the format ;;; ['-']+['/'+] or ['-']+'.'* or ;;; ['-']'.'+ Anything else except "." and "..." is a symbol. ;;; At some point this must be augmented to include general floats: ;;; ['-']{ *.+ | +['.'*] }[{'e'|'d'|'s'}*] (define (read-token stream) (let ((base #*input-base)) (labels (( (intern-it c r-charlist escaped?) ;; We're finished with this token, and it is a symbol. (unread-char stream c) (cond ((and (not escaped?) (eq? (car r-charlist) #\.) (null? (cdr r-charlist))) the-dot-token) (else (when (and (not escaped?) ;; For efficiency, ;; (equal r-charlist '(#\. #\. #\.)) ;; is expanded inline. Could this be a ;; compiler optimization? (eq? (car r-charlist) #\.) (let ((d1 (cdr r-charlist))) (and d1 (eq? (car d1) #\.) (let ((d2 (cdr d1))) (and d2 (eq? (car d2) #\.) (null? (cdr d2)))))) #|| (destructure** r-charlist (('#\. '#\. '#\.) (cerror "Treat the '...' as if it were escaped." "The token '...' can not be read unescaped.")) (otherwise )) ||# ) (cerror "Treat the '...' as if it were escaped." "The token '...' can not be read unescaped.")) (intern (#^string (reverse r-charlist))))) ) ( (digits1 c r-charlist n neg? first?) ;; We are in the first block of digits following the start of ;; the token. Preceded by an optional sign. ;; NEG? is whether a '-' started this token. ;; FIRST? is whether at least one digit has been read. (if (eq? c the-eof-token) (if first? (intern-it c r-charlist nil) (block (unread-char stream c) (if neg? (- n) n))) (let ((c-syntax (%vref/ci standard-read-table c))) (cond ((or (eq? c-syntax 'constituent) (and (not (eq? c-syntax 'whitespace)) (not (eq? c-syntax 'single-escape)) (not (eq? c-syntax 'illegal)) (eq? (car c-syntax) 'nonterminating-macro))) (cond ((digit? c base) (digits1 (read-char stream) (cons (upcase c) r-charlist) (+ (* n base) (digit-value c)) neg? #f)) ((and (not first?) (eq? c #\/)) (digits2 (read-char stream) (cons c r-charlist) 0 (if neg? (- n) n))) ((eq? c #\.) (digits3 (read-char stream) (cons c r-charlist) n 1 neg? first?)) (else (simple-symbol c r-charlist nil)))) ((eq? c-syntax 'single-escape) (read-escaped (read-char stream) r-charlist)) ((eq? c-syntax 'illegal) (simple-symbol c r-charlist nil)) ((or (eq? c-syntax 'whitespace) (eq? (car c-syntax) 'terminating-macro)) (if first? (intern-it c r-charlist nil) (block (unread-char stream c) (if neg? (- n) n)))) (else (signal bad-syntax-table-entry c c-syntax))))) ) ( (simple-symbol c r-charlist escaped?) ;; Reading something that appears to not be a number, ;; but that doesn't have any escaped characters yet. (if (eq? c the-eof-token) (intern-it c r-charlist escaped?) (let ((c-syntax (%vref/ci standard-read-table c))) (cond ((or (eq? c-syntax 'constituent) (and (not (eq? c-syntax 'whitespace)) (not (eq? c-syntax 'single-escape)) (not (eq? c-syntax 'illegal)) (eq? (car c-syntax) 'nonterminating-macro))) (simple-symbol (read-char stream) (cons (upcase c) r-charlist) escaped?)) ((eq? c-syntax 'illegal) (cerror "Ignore the illegal character" "Illegal char ~C encountered while reading token." c) (simple-symbol (read-char stream) r-charlist escaped?)) ((eq? c-syntax 'single-escape) (read-escaped (read-char stream) r-charlist)) ((or (eq? c-syntax 'whitespace) (eq? (car c-syntax) 'terminating-macro)) (intern-it c r-charlist escaped?)) (else (signal bad-syntax-table-entry c c-syntax))))) ) ( (read-escaped c r-charlist) ;; We just read an escape character, so the next one is ;; accepted literally. (when (eq? c the-eof-token) (signal eof-after-slash (#^string (reverse r-charlist)))) (simple-symbol (read-char stream) (cons c r-charlist) #t) ) ( (digits2 c r-charlist n numerator) ;; We're reading the block of digits following the '/' in ;; a fraction. (if (eq? c the-eof-token) (if (eq? (car r-charlist) #\/) (intern-it c r-charlist nil) (block (unread-char stream c) (/ numerator n))) (let ((c-syntax (%vref/ci standard-read-table c))) (cond ((or (eq? c-syntax 'constituent) (and (not (eq? c-syntax 'whitespace)) (not (eq? c-syntax 'single-escape)) (not (eq? c-syntax 'illegal)) (eq? (car c-syntax) 'nonterminating-macro))) (cond ((digit? c base) (digits2 (read-char stream) (cons (upcase c) r-charlist) (+ (* n base) (digit-value c)) numerator)) (else (simple-symbol c r-charlist #f)))) ((eq? c-syntax 'single-escape) (read-escaped (read-char stream) r-charlist)) ((eq? c-syntax 'illegal) (simple-symbol c r-charlist #f)) ((or (eq? c-syntax 'whitespace) (eq? (car c-syntax) 'terminating-macro)) (if (eq? (car r-charlist) #\/) (intern-it c r-charlist nil) (block (unread-char stream c) (/ numerator n)))) (else (signal bad-syntax-table-entry c c-syntax))))) ) ( (digits3 c r-charlist num denom neg? first?) ;; Reading digits after decimal point. ;; num is what numerator will be (except sign) if ends now. ;; denom is what denominator will be if ends now. ;; neg? is leading minus on number. ;; first? is true iff starting post-dot and there were no pre-dot digits. (if (eq? c the-eof-token) (if first? (intern-it c r-charlist nil) (form-decimal c num denom neg?)) (let ((c-syntax (%vref/ci standard-read-table c))) (cond ((or (eq? c-syntax 'constituent) (and (not (eq? c-syntax 'whitespace)) (not (eq? c-syntax 'single-escape)) (not (eq? c-syntax 'illegal)) (eq? (car c-syntax) 'nonterminating-macro))) (cond ((digit? c base) (digits3 (read-char stream) (cons (upcase c) r-charlist) (+ (* num base) (digit-value c)) (* denom base) neg? #f)) (else (simple-symbol c r-charlist #f)))) ((eq? c-syntax 'single-escape) (read-escaped (read-char stream) r-charlist)) ((eq? c-syntax 'illegal) (simple-symbol c r-charlist #f)) ((or (eq? c-syntax 'whitespace) (eq? (car c-syntax) 'terminating-macro)) (if first? (intern-it c r-charlist nil) (form-decimal c num denom neg?))) (else (signal bad-syntax-table-entry c c-syntax))))) ) ( (form-decimal c num denom neg?) (unread-char stream c) (let ((x (/ num denom))) (if neg? (- x) x)) ) ) (let* ((c (read-char stream)) (c-syntax (%vref/ci standard-read-table c))) (cond ((eq? c-syntax 'constituent) (cond ((eq? c #\-) (digits1 (read-char stream) (list c) 0 #t #t)) ((eq? c #\.) (digits3 (read-char stream) (list c) 0 1 #f #t)) (else (digits1 c nil 0 #f #t)))) ((eq? c-syntax 'single-escape) (read-escaped (read-char stream) nil)) (else (error "Internal error in reader: ~C of class ~A starts a token." c c-syntax))))))) (define (digit? c base) (let ((cn (#^number c))) (cond ((<= base 10) (and (<= (#^number #\0) cn) (< cn (+ (#^number #\0) base)))) (else (or (and (<= (#^number #\0) cn) (<= cn (#^number #\9))) (and (<= (#^number #\A) cn) (< cn (+ (#^number #\A) (- base 10)))) (and (<= (#^number #\a) cn) (< cn (+ (#^number #\a) (- base 10))))))))) (define (digit-value c) (let ((c (#^number c))) (cond ((<= c (#^number #\9)) (- c (#^number #\0))) ((<= c (#^number #\Z)) (- c (- (#^number #\A) 10))) (else (- c (- (#^number #\a) 10)))))) ;;; eof oaklisp-1.3.3.orig/src/world/kernel1-maketype.oak0000664000175000000620000000620607725515165020672 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang and Barak A. Pearlmutter ;;; how to make types (add-method (initialize (type instance-length variable-length? supertype-list ivar-list ivar-count type-bp-alist operation-method-alist top-wired?) self the-ivar-list the-supertype-list) (set! variable-length? nil) (set! supertype-list the-supertype-list) (set! ivar-list the-ivar-list) (set! ivar-count (%length ivar-list)) (set! operation-method-alist '()) (set! top-wired? nil) ;; Got to compute type-bp-alist and instance-length together: (set! instance-length 1) (set! type-bp-alist '()) (iterate nextsuper ((supers-to-do supertype-list)(type-table (list self)) (top-wired-guy? nil)(var-len-guy? nil)) (if supers-to-do (let ((guy (car supers-to-do))) (cond ((eq? guy variable-length-mixin) (when var-len-guy? (error "type init: can't include vl-mixin twice")) (set! variable-length? t) (set! instance-length 2) (nextsuper (cdr supers-to-do) type-table top-wired-guy? (list guy))) (((%slot 8) guy) (when top-wired-guy? (error "type init: can't combine two top-wired types")) (nextsuper (cdr supers-to-do) type-table (list guy) var-len-guy?)) ((%memq guy type-table) (nextsuper (cdr supers-to-do) type-table top-wired-guy? var-len-guy?)) (else (nextsuper (%append ((%slot 3) guy) (cdr supers-to-do)) (cons guy type-table) top-wired-guy? var-len-guy?)))) (block (when (and top-wired-guy? var-len-guy?) (error "type init: can't have both vl-mixin and a top-wired type")) (iterate layout ((guys-to-do (%append top-wired-guy? (%append type-table var-len-guy?)))) (if guys-to-do (let ((guy (car guys-to-do))) (set! type-bp-alist (cons (cons guy instance-length) type-bp-alist)) (set! instance-length (+ instance-length ((%slot 5) guy))) (layout (cdr guys-to-do))) self)))))) ;;; Value is: 0 for never add-methoded, NIL for regular operation, the method ;;; if it's a lambda. (add-method (initialize (operation lambda?) self) (set! lambda? 0) ;; The cache could be initialized to something innocent here, but I'm not ;; going to bother, as the uninitialized value shouldn't be a type anyway. self) (set! %your-top-wired (make operation)) (add-method (%your-top-wired (type top-wired?) self) (set! top-wired? t)) ;; fix the problem with subtyping a top-wired variable-length type. oaklisp-1.3.3.orig/src/world/vl-mixin.oak0000664000175000000620000001071707725515165017261 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;(initialize variable-length-mixin '() '()) ;; %VREF uses a magic instruction to index off the base pointer. (define-constant-instance %vref locatable-operation) (add-method (%vref (variable-length-mixin) self n) (let ((len (- ((%slot 1) self) ((%slot 1) (get-type self))))) (if (or (>= n len) (< n 0)) (error "%VREF index ~D into ~S out of bounds; limit is ~D." n self len) (%load-bp-i n)))) (add-method ((setter %vref) (variable-length-mixin) self n x) (let ((len (- ((%slot 1) self) ((%slot 1) (get-type self))))) (if (or (>= n len) (< n 0)) (error "SETTER %VREF index ~D into ~S out of bounds; limit is ~D." n self len) (set! (%load-bp-i n) x)))) (add-method ((locater %vref) (variable-length-mixin) self n) (let ((len (- ((%slot 1) self) ((%slot 1) (get-type self))))) (if (or (>= n len) (< n 0)) (error "LOCATE %VREF index ~D into ~S out of bounds; limit is ~D." n self len) (make-locative (%load-bp-i n))))) ;; We get the length by directly accessing the length field. This isn't ;; relative to the base pointer; it's part of the memory format of variable ;; length objects. (add-method (length (variable-length-mixin) self) (- ((%slot 1) self) ;total length of ourself in memory ((%slot 1) (get-type self)))) ;length of the non-variable-length part of ourself (add-method (initialize (variable-length-mixin) self ncells) self) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; the following operation does no bounds checking (define-constant-instance %vref-nocheck locatable-operation) (add-method (%vref-nocheck (variable-length-mixin) self n) (%load-bp-i n)) (add-method ((setter %vref-nocheck) (variable-length-mixin) self n x) (set! (%load-bp-i n) x)) (add-method ((locater %vref-nocheck) (variable-length-mixin) self n) (make-locative (%load-bp-i n))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Define the simple vector type: (define-constant-instance simple-vector coercable-type '() (list vector-type variable-length-mixin object)) ;;; Try to make only one empty vector. (let ((the-empty-vector (make simple-vector 0))) (add-method (initialize (simple-vector) self ncells) (if (zero? ncells) the-empty-vector self))) (add-method (nth (simple-vector) self n) (%vref self n)) (add-method ((setter nth) (simple-vector) self n x) (set! (%vref self n) x)) (add-method ((locater nth) (simple-vector) self n) (make-locative (%vref self n))) (add-method (#^simple-vector (list-type) l) (let* ((len (length l)) (v (make simple-vector len))) (iterate aux ((l l)(i 0)) (cond ((not (null? l)) (set! (nth v i) (car l)) (aux (cdr l) (+ i 1))) (else v))))) (add-method (#^list-type (simple-vector) v) (iterate aux ((i (- (length v) 1))(l '())) (if (negative? i) l (aux (- i 1) (cons (%load-bp-i i) l))))) #| (add-method (#^simple-vector (sequence) x) (let* ((len (length x)) (v (make simple-vector len))) (dotimes (i len v) (set! (nth v i) (nth x i))))) |# (let ((filler (make operation))) (add-method (filler (variable-length-mixin) v l) (iterate next ((i 0)(l l)) (when (not (null? l)) (set! (%load-bp-i i) (car l)) (next (1+ i)(cdr l))))) (add-method (#^simple-vector (list-type) x) (let* ((len (length x)) (v (make simple-vector len))) (filler v x) v))) (labels ((fill-it (lambda (i v a . args) (set! (nth v i) a) (if (zero? (rest-length args)) v (fill-it (+ i 1) v . args))))) (define (vector . args) (if (zero? (rest-length args)) (make simple-vector 0) (fill-it 0 (make simple-vector (rest-length args)) . args)))) #|| (define (vector . args) (listify-args #^simple-vector . args)) ||# ;;; eof oaklisp-1.3.3.orig/src/world/print-integer.oak0000664000175000000620000000557307725515165020311 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;;; How to print integers. Lets try to be fast out there... (define (digit->char x) (%fixnum->character (+ x (if (< x 10) (#^number #\0) (- (#^number #\A) 10))))) (define (print-place x place stream) (let ((q (quotient x place)) (r (remainder x place))) (write-char stream (digit->char q)) r)) (add-method (print (integer) self stream) (cond ((negative? self) (write-char stream #\-) (print (- self) stream) self) ((zero? self) (write-char stream #\0) self) (else (let ((base #*print-radix)) ;; Successive division; push onto list (iterate aux ((digits '()) (rem self)) (cond ((zero? rem) (dolist (d digits self) (write-char stream (digit->char d)))) (else (aux (cons (remainder rem base) digits) (quotient rem base))))))))) (add-method (print (fixnum) self stream) (cond ((negative? self) (write-char stream #\-) (print (- self) stream) self) ((zero? self) (write-char stream #\0) self) ((= #*print-radix 10) ;; Special case base 10. ;; Have to add another digit here is FIXNUMS get bigger, and take one ;; off if they get smaller. Because this goes in the cold world, ;; none of these can be bignums, as the world builder doesn't know ;; how to format them in memory. (labels ((d9 (lambda (q) (d8 (print-place q 100000000 stream)))) (d8 (lambda (q) (d7 (print-place q 10000000 stream)))) (d7 (lambda (q) (d6 (print-place q 1000000 stream)))) (d6 (lambda (q) (d5 (print-place q 100000 stream)))) (d5 (lambda (q) (d4 (print-place q 10000 stream)))) (d4 (lambda (q) (d3 (print-place q 1000 stream)))) (d3 (lambda (q) (d2 (print-place q 100 stream)))) (d2 (lambda (q) (d1 (print-place q 10 stream)))) (d1 (lambda (q) (write-char stream (digit->char q)) self))) (cond ((< self 10) (d1 self)) ((< self 100) (d2 self)) ((< self 1000) (d3 self)) ((< self 10000) (d4 self)) ((< self 100000) (d5 self)) ((< self 1000000) (d6 self)) ((< self 10000000) (d7 self)) ((< self 100000000) (d8 self)) (else (d9 self))))) (else (^super integer print self stream)))) ;;; eof oaklisp-1.3.3.orig/src/world/sort.oak0000664000175000000620000000552307725515165016504 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter ;;; A generic sorting facility. (define-instance sort operation) (define-instance sort! operation) (add-method (sort (sequence) v <=?) (sort! (copy v) <=?)) (add-method (sort! (sequence) v <=?) ;; This does a stupid bubble sort. Should be fixed. (let ((len (length v))) ;;(vsort v (make simple-vector len) 0 0 len) (when (> len 0) (dotimes (i (- len 1)) (iterate aux ((j (+ i 1))) (when (< j len) (when (<=? (nth v j) (nth v i)) (swap (nth v i) (nth v j))) (aux (+ j 1)))))) v)) ;;; Practice run for the Indiana Parenthesis Sweepstake Open: (labels ([sort-aux ;; Sort the first LEN elements of L. MERGER is used to ;; merge sublists. (lambda (l len <=? merger) (cond [(< len 2) l] [else (let* ([len/2 (quotient len 2)] [len/2b (- len len/2)] [lb (tail l len/2)]) (merger (sort-aux l len/2 <=? merger) len/2 (sort-aux lb len/2b <=? merger) len/2b <=?))]))] [merge!-aux ;; Destructively merges the first LENA guys of LA with the ;; first LENB guys of LB. (lambda (la lena lb lenb <=?) (cond [(zero? lena) lb] [(zero? lenb) la] [(not (<=? (car lb) (car la))) (set! (cdr la) (merge!-aux (cdr la) (- lena 1) lb lenb <=?)) la] [else (set! (cdr lb) (merge!-aux la lena (cdr lb) (- lenb 1) <=?)) lb]))] [merge-aux ;; Merge the first LENA guys of LA with the first LENB guys of LB. (lambda (la lena lb lenb <=?) (cond [(zero? lena) lb] [(zero? lenb) la] [else (let ([a (car la)] [b (car lb)]) (if (<=? b a) (cons b (merge-aux la lena (cdr lb) (- lenb 1) <=?)) (cons a (merge-aux (cdr la) (- lena 1) lb lenb <=?))))]))]) (add-method (sort! (list-type) l <=?) (let* ([len (length l)] [l (sort-aux l len <=? merge!-aux)]) (unless (zero? len) (set! (cdr (tail l (- len 1))) nil)) l)) (add-method (sort (list-type) l <=?) (let* ([len (length l)] [l (sort-aux l (length l) <=? merge-aux)]) (head l len)))) ;;; eof oaklisp-1.3.3.orig/src/world/continuation.oak0000664000175000000620000000762307725515165020232 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang ;;; First class continuations. The interface is call/cc, like it should be. (define-instance continuation type '(val-segs val-offset cxt-segs cxt-offset saved-windings saved-wind-count) (list object)) (%your-top-wired continuation) ;;;(add-method (length (type instance-length) self) ;;; instance-length) ;;;(define-constant %continuation-size (length continuation)) (define-constant %continuation-size 7) (set! %%cleanup-needed #f) (define (call/cc f) (bind () (block0 (%call/cc f) (when %%cleanup-needed (set! %%cleanup-needed #f) (rewind %%join-count %%new-windings %%new-wind-count))))) (define call-with-current-continuation call/cc) (define-constant %continue (add-method ((make-open-coded-operation (lambda (ignore) '((continue))) 2 1) (continuation) self v) (%continue self v))) (define-constant %fill-continuation (add-method ((make-open-coded-operation (lambda (ignore) '((fill-continuation))) 1 1) (continuation) self) (%fill-continuation self))) ;;; WARNING! CAUTION! Do not modify this definition of %CALL/CC ;;; unless you really know what you are doing. It is carefully tuned ;;; to leave exactly the right amount of stuff on the stack when ;;; %FILL-CONTINUATION is called. ;;; ;;; If the compiler is changed, it would be wise to make sure that ;;; this still works. (define (%call/cc f) (let ((tag (%fill-continuation (%allocate continuation %continuation-size)))) (set! ((%slot 5) tag) %windings) (set! ((%slot 6) tag) %wind-count) (f (lambda (v) (let ((join-count (find-join-point %windings %wind-count ((%slot 5) tag) ((%slot 6) tag)))) (unwind %windings %wind-count join-count) ;; We'd like to do this now, but we're in the wrong stack context, ;; so we'll remember to do it once we get there. ;;(rewind join-count ((%slot 5) tag) ((%slot 6) tag)) ;;This is the first time I've been forced to pass parameters by ;; stashing them in globals in Lisp! (set! %%join-count join-count) (set! %%new-windings ((%slot 5) tag)) (set! %%new-wind-count ((%slot 6) tag)) (set! %%cleanup-needed #t) ) (%continue tag v))))) #| ;;; This is the code generated by the preceding DEFINE: ((LOAD-CODE (CODE () ((CHECK-NARGS 1) (LOAD-IMM 5) (LOAD-GLO-CON CONTINUATION) (ALLOCATE) ;; F and the continuation object are on the stack here, and the saved ;; continuation should have the stack checkpointed without those ;; two guys on it. This is controled in the emulator code for the ;; fill-continuation instruction. (FILL-CONTINUATION) (MAKE-CELL) (LOAD-STK 0 TAG) (MAKE-CLOSED-ENVIRONMENT 1) ;; (LOAD-CODE (CODE () ((CHECK-NARGS 1) (LOAD-STK 0 V) (LOAD-ENV 2 TAG) (CONTENTS) (LOAD-GLO-CON %CONTINUE) (STORE-NARGS 2) (BLT-STK 3 1) (FUNCALL-TAIL)))) (LOAD-GLO-CON %INSTALL-LAMBDA-WITH-ENV) (STORE-NARGS 2) (FUNCALL-CXT) (LOAD-STK 2 F) (STORE-NARGS 1) (BLT-STK 2 2) (FUNCALL-TAIL)))) (LOAD-GLO-CON %INSTALL-LAMBDA) (STORE-NARGS 1) (FUNCALL-CXT) (LOAD-GLO %CALL/CC) (SET-CONTENTS) (RETURN)) |# ;;; eof oaklisp-1.3.3.orig/src/world/reader-errors.oak0000664000175000000620000002066307725515165020273 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang ;;; Define some types of errors to be signaled by the reader. (define-instance read-error type '() (list general-error)) (define-instance proceedable-read-error type '() (list proceedable-error read-error)) (define-instance unknown-construct type '() (list proceedable-read-error)) (define-instance error-in-# type '(char arg description) (list proceedable-read-error)) (define-instance unknown-#-macro type '() (list error-in-# unknown-construct object)) (define-instance cant-have-#-arg type '() (list error-in-# object)) (define-instance must-have-#-arg type '() (list error-in-# object)) (define-instance illegal-#-arg type '(reason) (list error-in-# object)) (define-instance list-end-error type '(list-so-far stuff-after-dot) '()) (define-instance unexpected-eof type '() (list read-error)) (define-instance eof-in-#pipe type '(level) (list error-in-# unexpected-eof object)) (define-instance eof-reading-until type '(list-so-far terminator) (list unexpected-eof object)) (define-instance eof-reading-chars-until type '(list-so-far terminator) (list unexpected-eof object)) (define-instance eof-after-slash type '(token-so-far) (list unexpected-eof object)) (define-instance eof-in-list-end type '() (list list-end-error unexpected-eof object)) (define-instance dot-in-list-end type '() (list list-end-error proceedable-read-error object)) (define-instance extra-object-in-list-end type '(thing) (list list-end-error proceedable-read-error object)) (define-instance illegal-dot-in-list type '(list-so-far terminator) (list proceedable-read-error object)) (define-instance dot-outside-list type '() (list proceedable-read-error object)) (add-method (initialize (dot-outside-list) self) (^super proceedable-read-error initialize self "Ignore the '.' token.")) (add-method (report (dot-outside-list) self stream) (format stream "A dot token (.) was read outside of a list.~%")) (add-method (initialize (list-end-error list-so-far stuff-after-dot) self the-lsf the-sad) (set! list-so-far the-lsf) (set! stuff-after-dot the-sad) self) (add-method (report (list-end-error list-so-far stuff-after-dot) self stream) (format stream "within the dotted ending of the list beginning ~S" list-so-far) (if stuff-after-dot (format stream " [ . ~S].~%" (car stuff-after-dot)) (format stream ".~%"))) (add-method (initialize (error-in-# char arg) self the-char the-arg) (set! char the-char) (set! arg the-arg) (^super proceedable-read-error initialize self (compose-proceed-message self))) (define-instance compose-proceed-message operation) (add-method (compose-proceed-message (error-in-# char arg) self) (format #f "the #~A~A construct." (or arg "") char)) (add-method (report (error-in-# char arg) self stream) (format stream "#~A~A construct" (if arg arg "") char)) (add-method (report (unknown-#-macro) self stream) (format stream "The ") (^super error-in-# report self stream) (format stream " is unknown.~%")) (add-method (compose-proceed-message (unknown-#-macro) self) (format #f "Ignore the ~A." (^super error-in-# compose-proceed-message self))) (add-method (report (cant-have-#-arg) self stream) (format stream "The ") (^super error-in-# report self stream) (format stream " is malformed; no argument is taken.~%")) (add-method (compose-proceed-message (cant-have-#-arg) self) (format #f "Ignore the illegal argument in the ~A." (^super error-in-# compose-proceed-message self))) (add-method (report (must-have-#-arg) self stream) (format stream "The ") (^super error-in-# report self stream) (format stream " requires an argument.~%")) (add-method (compose-proceed-message (must-have-#-arg) self) (format #f "Supply the required argument to the ~A." (^super error-in-# compose-proceed-message self))) (add-method (initialize (illegal-#-arg reason) self the-reason . args) (set! reason the-reason) (^super error-in-# initialize self . args)) (add-method (report (illegal-#-arg reason) self stream) (format stream "The contruct ") (^super error-in-# report self stream) (format stream "~A.~%" reason)) (add-method (compose-proceed-message (illegal-#-arg) self) (format #f "Supply an appropriate argument to the ~A." (^super error-in-# compose-proceed-message self))) (add-method (initialize (eof-in-#pipe level) self the-level) (set! level the-level) (^super unexpected-eof initialize self)) (add-method (report (eof-in-#pipe level) self stream) (if (= level 1) (format stream "EOF encountered within a #| ... |# construct.~%") (format stream "EOF encounted within ~D levels of #| ... |# constructs.~%" level))) (add-method (initialize (eof-reading-until list-so-far terminator) self the-list-so-far the-terminator) (set! list-so-far the-list-so-far) (set! terminator the-terminator) (^super unexpected-eof initialize self)) (add-method (report (eof-reading-until list-so-far terminator) self stream) (format stream "EOF reading a list to be terminated by a '~A' that began ~S.~%" terminator list-so-far)) (add-method (initialize (eof-reading-chars-until list-so-far terminator) self the-list-so-far the-terminator) (set! list-so-far the-list-so-far) (set! terminator the-terminator) (^super unexpected-eof initialize self)) (add-method (report (eof-reading-chars-until list-so-far terminator) self stream) (format stream "EOF reading a token to be terminated by a '~A' that began ~S~%" terminator list-so-far)) (add-method (initialize (eof-after-slash token-so-far) self the-token-so-far) (set! token-so-far the-token-so-far) (^super unexpected-eof initialize self)) (add-method (report (eof-after-slash token-so-far) self stream) (format stream "EOF after a '\\'; the token began ~S.~%" token-so-far)) (add-method (initialize (eof-in-list-end) self a b) (^super list-end-error initialize self a b) (^super unexpected-eof initialize self)) (add-method (report (eof-in-list-end) self stream) (format stream "EOF encountered ") (^super list-end-error report self stream)) (add-method (initialize (dot-in-list-end) self a b) (^super list-end-error initialize self a b) (^super proceedable-read-error initialize self "Ignore the extra dot.")) (add-method (report (dot-in-list-end) self stream) (format stream "Extra '.' encountered ") (^super list-end-error report self stream)) (add-method (initialize (extra-object-in-list-end thing) self the-thing a b) (set! thing the-thing) (^super list-end-error initialize self a b) (^super proceedable-read-error initialize self (format #f "Ignore the ~S." thing))) (add-method (report (extra-object-in-list-end thing) self stream) (format stream "Extra object (~S) encountered " thing) (^super list-end-error report self stream)) (add-method (initialize (illegal-dot-in-list list-so-far terminator) self the-list-so-far the-terminator) (set! list-so-far the-list-so-far) (set! terminator the-terminator) (^super proceedable-read-error initialize self "Ignore the dot token.")) (add-method (report (illegal-dot-in-list list-so-far terminator) self stream) (format stream "The '.' token was read in a list to be terminated with a '~A' that began ~S~%" terminator list-so-far)) (define-instance bad-syntax-table-entry type '(char entry) (list proceedable-read-error object)) (add-method (initialize (bad-syntax-table-entry char entry) self the-char the-entry) (set! char the-char) (set! entry the-entry) (^super proceedable-read-error initialize self (format #f "Ignore the unreadable character."))) (add-method (report (bad-syntax-table-entry char entry) self stream) (format stream "Malformed syntax table entry ~S encountered when reading a ~C.~%" entry char)) ;;; eof oaklisp-1.3.3.orig/src/world/weak.oak0000664000175000000620000000206007725515165016435 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter (define-constant object-hash (add-method ((make-open-coded-operation '((object-hash)) 1 1) (object) x) (object-hash x))) (define-constant object-unhash (add-method ((make-open-coded-operation '((object-unhash)) 1 1) (fixnum) x) (object-unhash x))) ;;; eof oaklisp-1.3.3.orig/src/world/operations.oak0000664000175000000620000001136707725515165017703 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Define open-codable operations. ;; (define-instance open-coded-mixin type '(byte-code-list n-arguments n-values) '()) (define-instance fixnum-open-coded-mixin type '() (list open-coded-mixin)) (define-instance locative-open-coded-mixin type '() (list open-coded-mixin)) (define-instance object-open-coded-mixin type '() (list fixnum-open-coded-mixin locative-open-coded-mixin)) (define-instance foldable-mixin type '() '()) (define-instance backwards-args-mixin type '() '()) ;;; Was for backward compatibility. ;;;(define no-side-effects-mixin foldable-mixin) (add-method (initialize (open-coded-mixin byte-code-list n-arguments n-values) self blist nargs nvals) (set! byte-code-list blist) (set! n-arguments nargs) (set! n-values nvals) ;; NOTE: this is a hack; mix-types should install an appropriate initialize ;; method, and then we'd be able to brag about mix-types more. ;; Okay, now for an explanation. Without the cond, you just ^super to ;; operation, and then settable- and locatable- operations don't get ;; initialized correctly, oops. (^super (cond ((is-a? self locatable-operation) locatable-operation) ((is-a? self settable-operation) settable-operation) (else operation)) initialize self)) (create-accessors open-coded-mixin get- byte-code-list n-arguments n-values) (define-instance oc-mixer mixin-manager) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Define locatable operations and contents. ;; The order of definitions here is very important. ;; (define-instance settable-operation type '(the-setter) (list operation)) (add-method (initialize (settable-operation the-setter) self) (set! the-setter (make operation)) (^super operation initialize self)) (define-instance locatable-operation type '(the-locater) (list settable-operation)) (define-constant-instance setter (mix-types oc-mixer (list foldable-mixin locatable-operation))) (add-method (setter (settable-operation the-setter) self) the-setter) (add-method ((setter setter) (settable-operation the-setter) self new-setter) (set! the-setter new-setter)) (define-constant-instance contents (mix-types oc-mixer (list locative-open-coded-mixin locatable-operation)) '((contents)) 1 1) (set! #|define-instance|# (setter contents) (make (mix-types oc-mixer (list locative-open-coded-mixin operation)) '((set-contents)) 2 1)) ;;; CONTENTS is open coded. (add-method (contents (locative) self) (contents self)) ;; As is (SETTER CONTENTS). (add-method ((setter contents) (locative) self new-value) (set! (contents self) new-value)) (add-method (initialize (locatable-operation the-locater) self) (set! the-locater (make operation)) (^super settable-operation initialize self) ;; It's harder to jam this guy down into the error system. (add-method ((setter self) (object) composite-object new-value) (when monitor-for-bruce (%write-char #\@)) (set! (contents (the-locater composite-object)) new-value)) #| (add-method (self (object) composite-object) (when monitor-for-bruce (%write-char #\%)) (contents (the-locater composite-object))) |# self) (define-constant-instance locater (mix-types oc-mixer (list foldable-mixin locatable-operation))) (add-method (locater (locatable-operation the-locater) self) the-locater) (add-method ((locater locater) (locatable-operation the-locater) self) (make-locative the-locater)) (set! #|define-instance|# (locater setter) (make operation)) (add-method ((locater setter) (settable-operation the-setter) self) (make-locative the-setter)) (set! #|define-instance|# (locater contents) (make (mix-types oc-mixer (list locative-open-coded-mixin operation)) '() 1 1)) (add-method ((locater contents) (locative) self) self) (define-constant-instance identity (mix-types oc-mixer (list object-open-coded-mixin operation)) '() 1 1) (add-method (identity (object) self) self) ;;; eof oaklisp-1.3.3.orig/src/world/make-makefile.oak0000664000175000000620000000515607725515165020207 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1992 Barak A. Pearlmutter & Kevin J. Lang (define (make-makefile name) (with-open-file (outfile name out) (let* ((aller (lambda (x) (format outfile " ~A.oa" (downcase (#^string x))))) (aller1 (lambda (x) (if (not (memq x between-files)) (aller x))))) (format outfile "# This included makefile data is automatically~%") (format outfile "# generated by make-makefile.oak, and should not~%") (format outfile "# normally be edited by hand. It can be regenerated~%") (format outfile "# with 'make Makefile-vars'.~%") (format outfile "~%") (format outfile "COLDFILES =") (for-each aller between-files) (for-each aller1 all-the-layers) (format outfile "~%") (format outfile "COLDFILESD =") (for-each aller all-the-layers) (format outfile "~%") (format outfile "MISCFILES =") (for-each aller misc-files) (format outfile "~%") (format outfile "COMPFILES =") (for-each aller compiler-files) (format outfile "~%") (format outfile "RNRSFILES =") (for-each aller scheme-files) (format outfile "~%") (format outfile "TOOLFILES = tool.oa~%") (format outfile "FILESFILES = files.oa~%") (format outfile "MAKEFILES = make-makefile.oa~%") (format outfile "~%") (format outfile "# These are gravy. The first two are our standard~%") (format outfile "# benchmarks. The others are neat.~%") (format outfile "~%") (format outfile "GRAVY = tak.oak compile-bench.oak prolog.oak prolog-examples.oak~%") (format outfile "~%") (format outfile "# Special rules for the compiler's source~%") (format outfile "~%") (for-each (lambda (f) (let ((f (downcase (#^string f)))) (format outfile "~a.oa:~a.oak;$(OAK) $(OAKFLAGS) -- -locale compiler-locale -compile $* -exit~%" f f))) compiler-files))) name) oaklisp-1.3.3.orig/src/world/backquote.oak0000664000175000000620000000755407725515165017501 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; This is borrowed from the T 2.8 sources, ;;; courtesy of Olin Grigsby Shivers III. ;;; Oaklisp Modifications ;;; Copyright (C) 1988 Barak A. Pearlmutter and Kevin J. Lang ;;; Oaklisp Mods: ;;; ;;; More-than-two arg append clause removed ;;; Appropriate (macro? system-locale X). ;;; Copyright (c) 1984 Yale University ;;;; Backquote ;;; BACKQUOTE: Support for the amazing ` read macro character. (define *BACKQUOTE* 'QUASIQUOTE) (define *COMMA* 'UNQUOTE) (define *COMMA-ATSIGN* 'UNQUOTE-SPLICING) (define *QUOTE* 'QUOTE) (DEFINE (QUOTATION? X) ; Crash your T compiler if this is integrable (AND (PAIR? X) (EQ? (CAR X) *QUOTE*) (PAIR? (CDR X)) (NULL? (CDDR X)))) (define (commation? x) (and (pair? x) (eq? (car x) *comma*) (pair? (cdr x)) (null? (cddr x)))) (define (comma-atsignation? x) (and (pair? x) (eq? (car x) *comma-atsign*) (pair? (cdr x)) (null? (cddr x)))) ;;; Seems to me that with appropriate continuation-passing and/or ;;; multi-value returns, the following could be rewritten to do much ;;; less list consing, e.g. none in the case of `(X Y Z). KMP claims ;;; it's not worth it, and I tend to believe him. -JAR (DEFINE (EXPAND-BACKQUOTE X) (COND ((NULL? X) ''()) ((vector? x) (let ((l (#^list-type x))) (cond ((any? comma-atsignation? l) (list '#^simple-vector (expand-backquote l))) (else (let ((l1 (map expand-backquote l))) (if (every? quotation? l1) (list 'quote x) (cons 'vector l1))))))) ((ATOM? X) (LIST 'QUOTE X)) ((eq? (CAR X) *BACKQUOTE*) (EXPAND-BACKQUOTE (EXPAND-BACKQUOTE (CADR X)))) ((eq? (CAR X) *COMMA*) (CADR X)) ; ,mumble ((AND (PAIR? (CAR X)) (eq? (CAAR X) *COMMA-ATSIGN*)) ;; (,@mumble ...) (LET ((SPLICE-IN (CADAR X)) (TAIL (EXPAND-BACKQUOTE (CDR X)))) (COND ((AND (QUOTATION? TAIL) (null? (CADR TAIL))) ;; Use FOO rather than (APPEND FOO '()) SPLICE-IN) ;; ;;Removed this clause for Oaklisp, since APPEND takes 2 args only. ;;((AND (PAIR? TAIL) (EQ? (CAR TAIL) 'APPEND)) ;; ;; (APPEND FOO (APPEND BAR BAZ)) => (APPEND FOO BAR BAZ) ;; (list* 'APPEND SPLICE-IN (CDR TAIL))) (else (LIST 'APPEND SPLICE-IN TAIL))))) (else (let ((car-x (car x)) (cdr-x (cdr x))) (LET ((A (EXPAND-BACKQUOTE car-x)) (D (EXPAND-BACKQUOTE cdr-x))) (COND ((QUOTATION? D) (let ((cadr-d (cadr d))) (COND ((QUOTATION? A) ;; (CONS 'FOO 'BAR) => '(FOO . BAR) (let ((cadr-a (cadr a))) (LIST 'QUOTE ;; Share structure if possible. (if (and (eq? car-x cadr-a) (eq? cdr-x cadr-d)) x (CONS cadr-a cadr-d))))) ((null? cadr-d) ;; (CONS FOO '()) => (LIST FOO) (LIST 'LIST A)) (else ;; (CONS FOO 'BAR) => (list* FOO 'BAR) (LIST 'list* A D))))) ((AND (PAIR? D) (MEMQ (CAR D) '(LIST list*))) ;; (CONS FOO (LIST . BAR)) => (LIST FOO . BAR) (list* (CAR D) A (CDR D))) (else (LIST 'list* A D)))))))) (define quasiquote-expander (lambda (form) (destructure* (#t x) form (expand-backquote x)))) (define-syntax quasiquote quasiquote-expander) ;;; eof oaklisp-1.3.3.orig/src/world/macros0.oak0000664000175000000620000001731507725515165017063 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Kevin J. Lang and Barak A. Pearlmutter ;;; This file goes in the cold load. It gets macros that absolutely must ;;; be in the cold load, or we'd get too mad. (define-syntax (make-locative place) (cond ((symbol? place) `(%make-locative ,place)) (else (let ((place (expand-groveling #*current-locale place))) (cond ((symbol? place) `(%make-locative ,place)) (else `((locater ,(car place)) ,@(cdr place)))))))) (define-syntax set (define-syntax set! (lambda (form) (destructure* (#t place value) form (labels ((normal (lambda (place) `((setter contents) (make-locative ,place) ,value)))) (if (symbol? place) (normal place) (let ((place (expand-groveling #*current-locale place))) (if (symbol? place) (normal place) `((setter ,(car place)) ,@(cdr place) ,value))))))))) (define-syntax (or . clauses) (if (null? clauses) ''#f (if (null? (cdr clauses)) (car clauses) (let ((var (genvar))) `(let ((,var ,(car clauses))) (if ,var ,var (or ,@(cdr clauses)))))))) (define-syntax (and . clauses) (cond ((null? clauses) 't) ((null? (cdr clauses)) (car clauses)) (else `(if ,(car clauses) (and ,@(cdr clauses)) '#f)))) (define-syntax if (lambda (form) (destructure** form ((#t test then-form) `(%if ,test ,then-form if-undefined-value)) ((#t test then-form else-form) `(%if ,test ,then-form ,else-form))))) ;;; Fancy COND that hacks =>'s. (define-syntax cond (lambda (form) (destructure** form ((#t) `cond-undefined-value) ((#t (guard) . clauses) `(or ,guard (cond ,@clauses))) ((#t (guard '=> op) . clauses) (let ((v (genvar))) `(let ((,v ,guard)) (if ,v (,op ,v) (cond ,@clauses))))) ((#t (guard . body) . clauses) `(if ,guard (block ,@body) (cond ,@clauses)))))) (let* ((make-add-method-expander (lambda (what) (lambda (form) (destructure* (#t (op . cdr-info-part) . body) form (let* ((bit (and cdr-info-part (pair? cdr-info-part) (list? (car cdr-info-part)))) (type-info (if bit (car cdr-info-part) ;; This hack makes (ADD-METHOD (X Y) ...) ;; put # in the .oa file. `(',object))) (args (if bit (cdr cdr-info-part) cdr-info-part)) (typ (car type-info)) (ivars (cdr type-info))) `(,what (,op (,typ ,@ivars) ,@args) (block ,@body))))))) (regular-expander (make-add-method-expander '%add-method))) (define-syntax native-add-method regular-expander) (define-syntax add-method regular-expander) (define-syntax _add-method (make-add-method-expander '_%add-method))) (define-syntax (lambda varlist . body) (let ((improper-part (improper-list? varlist))) (cond ((if improper-part (or (not (every? symbol? (make-proper varlist))) (not (symbol? improper-part))) (not (every? symbol? varlist))) (error "Malformed formal parameter list ~S." varlist)) (else `(add-method ((',make ',operation) ,@varlist) ,@body))))) #| (let ((f (lambda (form) (destructure* (#t rawclauses . body) form `(%labels ,(map (lambda (clause) (if (symbol? (car clause)) clause (destructure* ((var . args) . body) clause `(,var (lambda ,args ,@body))))) rawclauses) (block ,@body)))))) (define-syntax labels f) (define-syntax letrec f)) |# (let ((f (lambda (form) (destructure* (#t raw-clauses . body) form (let* ((canonical-clauses (map (lambda (clause) (if (symbol? (car clause)) clause (destructure* ((var . args) . body) clause `(,var (lambda ,args ,@body))))) raw-clauses)) (label-list (map first canonical-clauses)) (value-list (map second canonical-clauses)) (expanded-value-list (map (lambda (form) (expand-groveling #*current-locale form)) value-list))) (if (any? (lambda (x) (or (not (list? x)) (null? x) (not (eq? '%add-method (car x))))) expanded-value-list) `(let ,(map (lambda (lab) (list lab ''())) label-list) ,@(map (lambda (lab val) `(set! ,lab ,val)) label-list expanded-value-list) ,@body) `(%labels ,(map list label-list expanded-value-list) (block ,@body)) )))))) (define-syntax labels f) (define-syntax letrec f)) (define-syntax (let clauses . body) ;; For R3RS compatibility, make the LET into an ITERATE if it ;; starts with a symbol. (cond ((symbol? clauses) `(iterate ,clauses . ,body)) (else (dolist (clause clauses) (when (cddr clause) (cerror "Ignore it and proceed." "malformed clause ~S." clause))) `((lambda ,(map-and-reverse car clauses) ,@body) ,@(map-and-reverse cadr clauses))))) (define-syntax (iterate label clauses . body) (cond ((not (symbol? label)) (error "Illegal syntax in ITERATE; ~S must be a symbol." label)) (else `(labels (((,label ,@(map car clauses)) ,@body)) (,label ,@(map cadr clauses)))))) ;;;;;;;;;;;;;;;;; (define-syntax (the-runtime the-var) `(contents (identity (make-locative ,the-var)))) (define-syntax (fluid x) `(%fluid ',x)) ;(define-syntax (bind clauses . body) ; (let ((place1 (genvar)) (place2 (genvar))) ; `(let* ((,place1 (make-locative fluid-binding-list)) ; (,place2 (contents ,place1))) ; ,(if (null? clauses) ; 'nil ; `(set! (contents ,place1) ; (list* ,@(map (lambda (clause) ; (destructure* (('fluid var) val) clause ; `(cons ',var ,val))) ; clauses) ; ,place2))) ; (block0 (block ,@body) ; (set! (contents ,place1) ,place2))))) (define-syntax (bind clauses . body) (let ((old-binding-list (genvar))) `(let ((,old-binding-list (get-current-fluid-bindings))) ,(if (null? clauses) 'nil `(set-current-fluid-bindings (list* ,@(map (lambda (clause) (destructure* (('fluid var) val) clause `(cons ',var ,val))) clauses) ,old-binding-list))) (block0 (block ,@body) (set-current-fluid-bindings ,old-binding-list))))) (define-syntax (block0 form0 . body) (let ((v (genvar))) `(let ((,v ,form0)) ,@body ,v))) (define-syntax (block . body) `(%block ,@body)) ;;; DOLIST, again just like in Common Lisp, except that the variable isn't ;;; bound when the (optional) result form is evaluated. (define-syntax (dolist (var l . exit-body) . body) (let ((itt-var (genvar)) (v-label (genvar))) `(labels (( (,v-label ,itt-var) (if (null? ,itt-var) (block ,@exit-body) (let ((,var (car ,itt-var))) ,@body (,v-label (cdr ,itt-var)))) )) (,v-label ,l)))) (define-syntax (dolist-count (var l vari . exit-body) . body) (let ((itt-var (genvar)) (v-label (genvar))) `(labels (( (,v-label ,itt-var ,vari) (if (not (null? ,itt-var)) (let ((,var (car ,itt-var))) ,@body (,v-label (cdr ,itt-var) (+ 1 ,vari))) (block ,@exit-body)) )) (,v-label ,l 0)))) ;;; eof oaklisp-1.3.3.orig/src/world/list.oak0000664000175000000620000000672107725515165016471 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang & Barak A. Pearlmutter ;(define-instance backwards-args-mixin type '() '()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; handy list utilities ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (iota n) (iterate step ((i n)(l '())) (if (zero? i) l (step (- i 1) (cons i l))))) (define (iota0 n) (iterate step ((i (- n 1)) (l '())) (if (< i 0) l (step (- i 1) (cons i l))))) (define (splice inlist) ;this performs ((a)(b c)(d)) --> (a b c d) (iterate step ((in (reverse inlist)) (out '())) (if (not (null? in)) (step (cdr in) (append (car in) out)) out))) ;;;;;;;;;;;;;;;; (define-constant-instance list (mix-types oc-mixer (list backwards-args-mixin open-coded-mixin operation)) (lambda (n) (cons '(load-reg nil) (make list-type n '(reverse-cons)))) nil 1) (labels (((list-aux1 a) (list a)) ((list-aux2 a b) (list a b)) ((list-aux3 a b c) (list a b c)) ((list-aux4 a b c d) (list a b c d)) ((list-aux5 a b c d e) (list a b c d e))) (add-method (list (object) . rest) (cond ((= 0 (rest-length rest)) '()) ((= 1 (rest-length rest)) (list-aux1 . rest)) ((= 2 (rest-length rest)) (list-aux2 . rest)) ((= 3 (rest-length rest)) (list-aux3 . rest)) ((= 4 (rest-length rest)) (list-aux4 . rest)) ((= 5 (rest-length rest)) (list-aux5 . rest)) (else (listify-args identity . rest))))) ; listify-args now gets the arguments ; off the stack more cheaply than this older code ; ((list-aux-gen listsofar guy . rest) ; (if (zero? (rest-length rest)) ; (reverse! (cons guy listsofar)) ; (list-aux-gen (cons guy listsofar) . rest)))) ; (else (list-aux-gen '() . rest))))) ;;;;;;;;;;;;;;;; (define-constant-instance list* (mix-types oc-mixer (list backwards-args-mixin open-coded-mixin operation)) (lambda (n) (cond ((zero? n) (error "Attempt to open code LIST* with no args.")) (else (make list-type (- n 1) '(reverse-cons))))) nil 1) (labels (((list*-aux1 a) (list* a)) ((list*-aux2 a b) (list* a b)) ((list*-aux3 a b c) (list* a b c)) ((list*-aux-gen listsofar guy . rest) (if (zero? (rest-length rest)) (reverse!* listsofar guy) (list*-aux-gen (cons guy listsofar) . rest))) ((reverse!* l dot-part) (iterate aux ((old l) (new dot-part)) (cond (old (let ((o (cdr old))) (set! (cdr old) new) (aux o old))) (else new))))) (add-method (list* (object) one . rest) (cond ((= 0 (rest-length rest)) (list*-aux1 one . rest)) ((= 1 (rest-length rest)) (list*-aux2 one . rest)) ((= 2 (rest-length rest)) (list*-aux3 one . rest)) (else (list*-aux-gen '() one . rest))))) ;;; eof oaklisp-1.3.3.orig/src/world/mac-comp-stuff.oak0000664000175000000620000000711107725515165020331 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Kevin J. Lang and Barak A. Pearlmutter (define-instance get-ivar-list operation) (add-method (get-ivar-list (type ivar-list) self) ivar-list) (define-instance side-effect-free? operation) (add-method (side-effect-free? (object) self) #f) (add-method (side-effect-free? (foldable-mixin) self) #t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; set utility functions ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (subset? x y) (null? (setdifference x y))) (define-instance map-with-arg operation) (add-method (map-with-arg (operation) op l arg) (if (null? l) '() (cons (op (car l) arg) (map-with-arg op (cdr l) arg)))) (define-instance walk-with-arg operation) (add-method (walk-with-arg (operation) op l arg) (iterate step ((left l)) (when (not (null? left)) (op (car left) arg) (step (cdr left))))) (define (rib-lookup keys vals thing) (let ((pos (position-in-list thing keys))) (if pos (nth vals pos) (error "Can't find ~S in rib ~S" thing keys)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Things that must be set up in compiler locale. ;;; ;;; ;;; ;;; Perhaps this stuff should go into a seperate file that goes into ;;; ;;; compiler-locale. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-constant _%install-method-with-env (make-open-coded-operation (lambda (n) (if (not (= n 4)) (error "_%install-method-with-env takes 4 args, not ~A." n) (let ((l0517 (gensym "L-IM-")) (l0518 (gensym "L-IM-")) (l0519 (gensym "L-IM-")) (l0520 (gensym "L-IM-"))) `(;;(CHECK-NARGS 4) (LOAD-IMM 3) (LOAD-GLO %METHOD) (CONTENTS) (ALLOCATE) (LOAD-STK 3 CODE-BODY) (LOAD-STK 1 THE-METHOD) (STORE-SLOT 1) (POP 1) (LOAD-STK 4 ENV) (LOAD-STK 1 THE-METHOD) (STORE-SLOT 2) (POP 1) (LOAD-GLO OBJECT) (CONTENTS) (LOAD-STK 2 TYP) (EQ?) (BRANCH-NIL ,L0519) (LOAD-STK 2 OP) (LOAD-SLOT 1) (BRANCH ,L0520) (LABEL ,L0519) (LOAD-REG NIL) (LABEL ,L0520) (BRANCH-NIL ,L0517) (LOAD-STK 0 THE-METHOD) (LOAD-STK 3 OP) (STORE-SLOT 1) (BRANCH ,L0518) (LABEL ,L0517) (LOAD-STK 1 TYP) (LOAD-SLOT 7) (LOAD-STK 1 THE-METHOD) (LOAD-STK 4 OP) (CONS) (CONS) (LOAD-STK 2 TYP) (STORE-SLOT 7) (POP 1) (LOAD-REG NIL NIL) (LOAD-STK 3 OP) (STORE-SLOT 1) (LABEL ,L0518) (POP 3) (BLT-STK 1 2) ;;(RETURN) )))) nil 1)) ;(freeze-guys flat-compiler-locale ; '( _%install-method-with-env %make-closed-environment %make-cell)) oaklisp-1.3.3.orig/src/world/kernel0types.oak0000664000175000000620000000501407725515165020135 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Barak A. Pearlmutter & Kevin J. Lang ;;; This program defines some types in a crude way so that ;;; we can send messages to everything. ;;; Most of these these types must be adjusted later in the boot ;;; process so that their inheritance relationships will be correct. (set! ((%slot 0) %code-vector) type) (set! ((%slot 0) cons-pair) type) (set! ((%slot 0) string) type) (set! %method (%allocate type 9)) (set! %closed-environment (%allocate type 9)) (set! null-type (%allocate type 9)) (set! fixnum (%allocate type 9)) (set! locative (%allocate type 9)) (set! ((%register 'fixnum-type)) (the-runtime fixnum)) ;(set! ((%register 'cons-type)) (the-runtime cons-pair)) (set! ((%register 'loc-type)) (the-runtime locative)) (set! ((%register 'env-type)) (the-runtime %closed-environment)) (set! ((%register 'method-type)) (the-runtime %method)) (set! ((%register 'operation-type)) (the-runtime operation)) ;; The MAKE-CLOSED-ENVIRONMENT instruction has been modified to disallow ;; an argument of 0: ;(set! %empty-environment (%make-closed-environment)) (set! %empty-environment (%varlen-allocate %closed-environment 2)) (let ((booter ((%register 'boot-code)))) (set! ((%slot 0) booter) %method) (set! ((%slot 2) booter) %empty-environment)) (set! %sort-of-init (%allocate operation %simple-operation-length)) (set! ((%slot 1) %sort-of-init) 0) (_add-method (%sort-of-init (type supertype-list type-bp-alist operation-method-alist) self) (set! supertype-list (list object)) (set! type-bp-alist `((,self . 1))) (set! operation-method-alist nil)) (%sort-of-init %code-vector) (%sort-of-init cons-pair) (%sort-of-init string) (%sort-of-init %method) (%sort-of-init %closed-environment) (%sort-of-init null-type) (%sort-of-init fixnum) (%sort-of-init locative) (set! ((%slot 0) '()) null-type) oaklisp-1.3.3.orig/src/world/prolog.oak0000664000175000000620000005020007725515165017007 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;;; Copyright (C) 1993 Barak A. Pearlmutter & Kevin J. Lang ;;; The "relation" is the main interface between normal Oaklisp and ;;; the logic subsystem. ;;; Syntax: the RELATION form returns a function of n+1 variables, ;;; where n is the arity of the relation. This function takes a ;;; continuation as its first argument, and the normal relational ;;; arguments as the rest. Each time a solution is obtained, the ;;; continuation is called. When all solutions have been exhausted, ;;; the relation itself returns. ;;; Inside the relation form is a list of clauses. Each clause begins ;;; with a list of logic variables used, followed by the left hand ;;; side of the clause. Then there is an optional :- followed by the ;;; right hand side of the clause. The right hand side consists of ;;; three things: references to other relations, notated by what looks ;;; like a function call; calls to normal Oaklisp predicates, notated ;;; by a comma followed by the call; and Prolog style cuts, notated by ;;; an !. Calls to normal oaklisp predicates affect the control flow ;;; in the same way as calls to prolog relations. ;;; Within calls to other relations, logic variables are preceded by ;;; commas. Actually, within calls to other relations, any expression ;;; following a comma will be evaluated as an Oaklisp expression, ;;; making arithmetic convenient. ;;; Within calls to Oaklisp relations, the clause's logic variables ;;; may be accessed normally. ;;; Within any Oaklisp code, bound logic variables are transparently ;;; and silently replaced by their values when appropriate, so no ;;; machinations should be necessary. ;;; [Actually, your program will run faster if bound logic variables ;;; are explicitly derefenced before being passed to oaklisp code. ;;; You can do this using using follow-chain if you know that ;;; following the chain of variables will lead to an atomic value such as ;;; a number, or deep-copy if the variable is bound to a more complicated ;;; data structure containing cons cells as well as logic variables.] ;;; As a special dispensation, Oaklisp set! forms are allowed to appear in ;;; the right hand side to provide a faster version of part of the ;;; functionality of the prolog relation "is". A set! clause is ;;; performed for effect only and control is then passed to the clause to the ;;; right regardless of the value to which the variable has been bound. ;;; Set! should only be used to calculate initial values for temporary RHS ;;; variables that will be then used in clauses that are further to the right. ;;; It cannot be used to pass values back to the caller of the relation ;;; through LHS variables; for that purpose, one must use the "is" relation ;;; to unify the LHS variable with the new value. (define-syntax (relation . clauses) (let* ((k (genvar)) (arity (length (cdadar clauses))) (formals (map genvar/1 (iota arity))) (cformals (map (lambda (x) (list 'unquote x)) formals)) (lhs-names (map caadr clauses)) (!? (has-! clauses)) (!tag (if !? (genvar)))) (dolist (x lhs-names) (unless (eq? x (car lhs-names)) (cerror "ignore" "LHS relation dummy ~S when first was ~S." x (car lhs-names)))) (let ((body (process-clauses clauses cformals k `(throw ,!tag #f)))) (if !? `(lambda (,k ,@formals) (native-catch ,!tag ,body)) `(lambda (,k ,@formals) ,body))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ?- is the main user interface to the logic programming subsystem. ;;; To use it, you go (?- query ...) where "query ..." is in the same ;;; syntax as the right hand side of a clause. ;;; The macro automatically determines a list of logic variables ;;; scoped to the query itself, putting any variable which occurs ;;; alone after a comma on the list. To indicate that this isn't what ;;; you want (e.g. you want to refer to an ordinary oaklisp variable), ;;; you have to write something like ,(BLOCK GV). ;;; Each time that a solution is found, the values of all the logic ;;; variables scoped to the query itself are printed, and the user is ;;; asked whether more solutions should be found or the search terminated. ;;; Example: ;;; > (?- (p-member ,a ,(iota 5))) ;;; A=1 more? ;;; A=2 more? ;;; A=3 more? ;;; A=4 more? ;;; A=5 more? ;;; () ;;; > (define-syntax (?- . queries) (let ((l (logic-varlist queries)) (done (genvar))) (if (null? l) ; if there are no variables in the query, we report its truth value, ; but do not search for extra ways of satisying a true statement. `(native-catch ,done ,(process-rhs queries `(lambda () (throw ,done #t)) `(throw ,done #f))) `(with-logic-vars ,l (native-catch ,done ,(process-rhs queries `(lambda () ,@(map (lambda (v) `(format #t "~A=~S " ',v ,v)) l) (unless (y-or-n? "more") (throw ,done #t))) `(throw ,done #f))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; this is similar to the ?- macro, but instead of pausing ; to print the satisfying assignments, it collects them in a list. (define-syntax (collect-solutions . queries) (let ((l (logic-varlist queries)) (done (genvar)) (solutions (genvar)) (workvar (genvar))) (cond ((zero? (length l)) (error "collect-solutions makes no sense ~a" "when the query contains no logic variables")) ((= 1 (length l)) `(with-logic-vars ,l (let ((,solutions '())) (native-catch ,done ,(process-rhs queries `(lambda () (set! ,solutions (cons (deep-copy ,(car l)) ,solutions))) `(throw ,done #f))) (reverse! ,solutions))) ) (else `(with-logic-vars ,l (let ((,solutions '())) (native-catch ,done ,(process-rhs queries `(lambda () (let ((,workvar '())) ,@(map (lambda (v) `(set! ,workvar (cons (deep-copy ,v) ,workvar))) (reverse l)) (set ,solutions (cons ,workvar ,solutions)))) `(throw ,done #f))) (reverse! ,solutions))) ) ))) (define (deep-copy x) (let ((x (follow-chain x))) (cond ((eq? x _) _) ((logic-variable? x) x) ; used to be (make regular-logic-variable) ((pair? x) (let ((a (deep-copy (car x))) (d (deep-copy (cdr x)))) (if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a d)))) (else x)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Use this macro if you want prolog to just run through the various ; solutions without doing anything with them. This is useful for ; benchmarking, or when oaklisp side effects are used inside the ; prolog program to record the answers. (define-syntax (justrun . queries) (let ((l (logic-varlist queries)) (done (genvar))) `(with-logic-vars ,l (native-catch ,done ,(process-rhs queries `(lambda () nil) `(throw ,done #f)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Logic variables can be integrated with the rest of the Oaklisp ;;; language in a principled way. In this file we first define a new ;;; kind of forcible object, a logic variable, and then use it to ;;; write a general unifier with the ability to back out of ;;; unifications. This in turn is used to build a prolog system which ;;; is slightly compiler-based, and which is integrated seamlessly ;;; with the rest of Oaklisp. (define-instance logic-variable type '() (list forcible)) (add-method (force (logic-variable) self) (error "Attempt to force ~S, an undetermined logic variable." self)) ;;; Note: A reserved object, a special unbound logic variable value, ;;; could be stored in the val slot, eliminating the need for the flag. (define-instance regular-logic-variable type '(flag val) (list logic-variable object)) (add-method (initialize (regular-logic-variable flag) self) (set! flag #f) self) (add-method (force (regular-logic-variable flag val) self) (if flag val (^super logic-variable force self))) (add-method (print (regular-logic-variable flag val) self stream) (if (and flag #*forcible-print-magic) (^super logic-variable print self stream) (format stream "#_~!" self))) (add-method (print (regular-logic-variable flag val) self stream) (if (and flag #*forcible-print-magic) (^super logic-variable print self stream) (format stream "#_~!" self))) (add-method (print (regular-logic-variable flag val) self stream) (cond ((and flag #*forcible-print-magic) (^super logic-variable print self stream)) (else (format stream "#_~!" self)))) (add-method (print-list-end (regular-logic-variable flag val) self . args) (if (and flag #*forcible-print-magic) (print-list-end (force self) . args) (^super object print-list-end self . args))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; For convenience and efficiency, _ is bound to a magic logic ;;; variable that doesn't really get unified to things. (define-instance anonymous-logic-variable type '() (list logic-variable object)) (add-method (print (anonymous-logic-variable) self stream) (format stream "#_")) (define-instance _ anonymous-logic-variable) ;;; For efficiency, this is used, once, deep inside the unifier. (define-instance follow-chain operation) (add-method (follow-chain (regular-logic-variable flag val) self) (if flag (follow-chain val) self)) (add-method (follow-chain (object) self) self) (define logic-variable? (type-pred logic-variable)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This gets passed two args and a continuation, which is called when ;;; the args are unified. Then the unification is backed out of, and ;;; then unify returns. (define-instance unify operation) (add-method (unify (regular-logic-variable flag val) self other k) (cond ((eq? self other) (k)) (flag (unify val other k)) (else ;; The wind-protect wouldn't have to protect the entry part ;; except for first class continuations. The exit part is ;; protected because ! FAIL does a throw. (wind-protect (block (set! val other) (set! flag #t)) (k) (block (set! flag #f) (set! val #f)))))) (add-method (unify (object) self other k) (let ((other (follow-chain other))) (cond ((eq? self other) (k)) ((logic-variable? other) (unify other self k)) ;; ?? ;; ((equal? self other) (k)) ((and (pair? self) (pair? other)) (unify (car self) (car other) (let ((cdr-self (cdr self)) (cdr-other (cdr other))) (lambda () (unify cdr-self cdr-other k))))) ;; ((and (eq? (get-type self) (get-type other)) (= (%get-length self) (%get-length other)) (= (%tag self) %pointer-tag)) (slotsky-unify self (%set-tag self %locative-tag) other (%set-tag other %locative-tag) 1 (%get-length self) k)) (else #f)))) (add-method (unify (anonymous-logic-variable) a b k) (k)) (define (slotsky-unify o0 loc0 o1 loc1 i len k) (if (= i len) (k) (unify (contents (%increment-locative loc0 i)) (contents (%increment-locative loc1 i)) (lambda () (slotsky-unify o0 loc0 o1 loc1 (+ i 1) len k))))) ;;; A macro for making some logic variables for a while. (define-syntax (with-logic-vars varlist . body) `(let ,(map (lambda (v) `(,v (make regular-logic-variable))) varlist) ,@body)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (labels (((ordered-union a b) (iterate next ((a (reverse a))(b b)) (cond ((null? a) b) ((memq (car a) b) (next (cdr a) b)) (else (next (cdr a) (cons (car a) b))))))) (define (logic-varlist x) (cond ((comma-expr? x) (cond ((pair? (cadr x)) '()) ((eq? (cadr x) '_) '()) ; don't shadow global logic var _ (else (list (cadr x))))) ((pair? x) (ordered-union (logic-varlist (car x)) (logic-varlist (cdr x)))) (else '())))) (define (y-or-n? prompt) (iterate aux () (format #t "~A? " prompt) (flush standard-output) (flush standard-input) (let ((c (read-char standard-input))) (cond ((eq? c #\newline) #t) ((eq? c #\y) (read-char standard-input) #t) ((eq? c #\n) (read-char standard-input) #f) (else (format #t "type ('y' or #\newline) or 'n' ... ~%") (aux)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Some stuff for dealing with reader syntax and backquotes and such. ;;; Is x of the form ,x ? (define (comma-expr? x) (and (pair? x) (eq? (car x) 'unquote))) ;;; Like putting a backquote in front of something: (define (backquotify x) (list 'quasiquote x)) ;;; This emits code that unifies the expressions e1 and e2, executes ;;; the code, ununifies them, and returns. (define (sym-unify e1 e2 code) (cond ((or (comma-expr? e1) (comma-expr? e2)) (if (or (equal? e1 ',_) (equal? e2 ',_)) code `(unify ,(backquotify e1) ,(backquotify e2) ,(lambdify code)))) ((and (pair? e1) (pair? e2)) (sym-unify (car e1) (car e2) (sym-unify (cdr e1) (cdr e2) code))) ((equal? e1 e2) code) (else (warning "Unable to symbolically unify ~s and ~s." e1 e2) '#f))) ;;; This takes a chunk of code, and makes it into a chunk of code that ;;; returns a function which, if called, does the same thing as the ;;; original code. (define (lambdify code) (destructure** code ((x) x) (otherwise `(lambda () ,code)))) (define (has-! clauses) (and (not (null? clauses)) (or (memq '! (cddar clauses)) (has-! (cdr clauses))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (process-clauses clauses cformals k cutfail) (if (null? clauses) '#f (process-clause (car clauses) cformals k (process-clauses (cdr clauses) cformals k cutfail) cutfail))) (define (process-clause clause formals k failcode cutfail) (destructure** clause ((vars lhs) (set save-vars vars) (set save-lhs lhs) `(block (with-logic-vars ,vars ,(sym-unify formals (cdr lhs) `(,k))) ,failcode)) ((vars lhs ':- . rhs) (set save-vars vars) (set save-lhs lhs) (set save-rhs rhs) `(block (with-logic-vars ,vars ,(sym-unify formals (cdr lhs) (process-rhs rhs k cutfail))) ,failcode)))) (define (process-rhs rhs k cutfail) (if (null? rhs) `(,k) (let ((munched-rest (process-rhs (cdr rhs) k cutfail))) (cond ((eq? (car rhs) '!) `(block ,munched-rest ,cutfail)) ((comma-expr? (car rhs)) `(when ,(cadar rhs) ,munched-rest)) (else `(,(caar rhs) ,(lambdify munched-rest) ,@(map backquotify (cdar rhs)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (is k x y) (unify x y k)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Here is a more complicated version that contains a couple ; of optimizations which improves speed on the knights-tour ; problem by about a factor of 2. ; When a variable first occurs on the left hand side as ; a bare match with an input argument, we just use let ; to bind an oaklisp variable to whatever value came in, rather ; than making a new logical variable and then unifying it ; with the incoming argument. ; Also we provide a mechanism for set! so that temporary ; RHS variables can be implemented as ordinary oaklisp variables. (define (analyse-lhs-variables input-list) (let* ((vars-to-copy '()) (seen-it '()) (hacked-list (map (lambda (expr expr-no) (if (comma-expr? expr) (let ((the-variable (cadr expr))) (if (memq the-variable seen-it) expr (block (set seen-it (cons the-variable seen-it)) (set vars-to-copy (cons (cons the-variable expr-no) vars-to-copy)) (list 'unquote 'first-reference the-variable) ))) (block (set seen-it (union seen-it (all-atoms-in expr))) expr))) input-list (iota0 (length input-list)) ))) (list (reverse vars-to-copy) hacked-list))) (define (all-atoms-in inlist) (cond ((pair? inlist) (union (all-atoms-in (car inlist)) (all-atoms-in (cdr inlist)))) ((null? inlist) '()) (else (list inlist)))) (define (sym-unify e1 e2 code) (cond ((and (comma-expr? e1) (comma-expr? e2) (= 3 (length e2)) (eq? 'first-reference (second e2))) ; the value was directly copied by hacked-with-logic-vars, ; so we don't need to unify here. code) ((or (comma-expr? e1) (comma-expr? e2)) (cond ((or (equal? e1 ',_) (equal? e2 ',_)) code) ; not always a win ; ((or (null? e2) (number? e2) (symbol? e2)) ; `(when (unifiable-with-constant? ,(backquotify e1) ,(backquotify e2)) ; (unify ,(backquotify e1) ; ,(backquotify e2) ; ,(lambdify code)))) (else `(unify ,(backquotify e1) ,(backquotify e2) ,(lambdify code))))) ((and (pair? e1) (pair? e2)) (sym-unify (car e1) (car e2) (sym-unify (cdr e1) (cdr e2) code))) ((equal? e1 e2) code) (else (warning "Unable to symbolically unify ~s and ~s." e1 e2) '#f))) (define-syntax (hacked-with-logic-vars varlist formal-list lhs-vars-to-copy rhs-vars-to-set . body) `(let ,(map (lambda (v) (cond ((assq v lhs-vars-to-copy) ; Copy the incoming argument now so that ; we don't have to unify later. `(,v ,(nth formal-list (cdr (assq v lhs-vars-to-copy))))) ((memq v rhs-vars-to-set) ; we are going to assign a value later with set!, ; we don't need to make a logic variable now. `(,v variable-undefined-value)) (else `(,v (make regular-logic-variable))))) varlist) ,@body)) (define (process-clause clause formals k failcode cutfail) (destructure** clause ((vars lhs) (let* ((result (analyse-lhs-variables (cdr lhs))) (vars-to-copy (car result)) (hacked-lhs (second result))) `(block (hacked-with-logic-vars ,vars ,(map second formals) ,vars-to-copy () ,(sym-unify formals hacked-lhs `(,k))) ,failcode))) ((vars lhs ':- . rhs) (bind ((#*rhs-vars-to-set '())) (let* ((result (analyse-lhs-variables (cdr lhs))) (vars-to-copy (car result)) (hacked-lhs (second result)) (processed-rhs (process-rhs rhs k cutfail))) `(block (hacked-with-logic-vars ,vars ,(map second formals) ,vars-to-copy ,#*rhs-vars-to-set ,(sym-unify formals hacked-lhs processed-rhs)) ,failcode)))))) (define (process-rhs rhs k cutfail) (if (null? rhs) `(,k) (let ((munched-rest (process-rhs (cdr rhs) k cutfail))) (cond ((eq? (car rhs) '!) `(block ,munched-rest ,cutfail)) ; this is the special hack for set! forms ((let ((x (car rhs))) (and (comma-expr? x) (pair? (second x)) (= 3 (length (second x))) (memq (car (second x)) '(set set!)))) (set #*rhs-vars-to-set (cons (second (second (car rhs))) #*rhs-vars-to-set)) `(block ,(second (car rhs)) ,munched-rest)) ((comma-expr? (car rhs)) `(when ,(cadar rhs) ,munched-rest)) (else `(,(caar rhs) ,(lambdify munched-rest) ,@(map backquotify (cdar rhs)))))))) ; (define-instance unifiable-with-constant? operation) ; ; (add-method (unifiable-with-constant? (regular-logic-variable flag val) ; self the-constant) ; (if flag ; (unifiable-with-constant? val the-constant) ; #t)) ; ; (add-method (unifiable-with-constant? (object) self the-constant) ; (eq? self the-constant)) ;;; eof oaklisp-1.3.3.orig/src/world/da.oak0000664000175000000620000000134707725515165016101 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA (%write-char #\-) oaklisp-1.3.3.orig/src/world/peephole.oak0000664000175000000620000001465707725515165017326 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Barak A. Pearlmutter and Kevin J. Lang ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; peephole optimizer ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This is a rewrite of the peephole optimizer that should both ;;; faster and more modular. ;;; Interface function: (peephole-optimize instruction-list). Extra fields ;;; in the instructions are comments. Labels are bare symbols in the list. (local-syntax peep (lambda (form) `(define-crunch peephole ,@(cdr form)))) ;;; Single instruction optimizations: (peep (BLAST 1) => (BLT-STK 1 1)) (peep (POP 0) => ) (peep (BLT-STK ,n 0) => ) (peep (BLT-STK 0 ,n) => (POP ,n)) ;(peep (NOOP) => ) ;;; Pure branches: (peep (LABEL ,l) (BRANCH ,l) => 1 (load-glo-con infinite-loop) (load-glo-con signal)(store-nargs 1) (funcall-cxt)) (peep (forall x branch in0) (,x ,l) (LABEL ,l) => 2) (peep (forall x branch in1) (,x ,l) (LABEL ,l) => (POP 1) 2) ;;; Branch interactions: (peep (NOT)(BRANCH-NIL ,l) => (BRANCH-T ,l)) (peep (NOT)(BRANCH-T ,l) => (BRANCH-NIL ,l)) (peep (forall x in0 out1 notnil nosides)(,x)(BRANCH-T ,l) => (BRANCH ,l)) (peep (forall x in0 out1 notnil nosides)(,x)(BRANCH-NIL ,l) => ) (peep (forall x in1 out1 notnil nosides)(,x)(BRANCH-T ,l) =>(POP 1)(BRANCH ,l)) (peep (forall x in1 out1 notnil nosides)(,x)(BRANCH-NIL ,l) => (POP 1)) (peep (forall x in2 out1 notnil nosides)(,x)(BRANCH-T ,l) =>(POP 2)(BRANCH ,l)) (peep (forall x in2 out1 notnil nosides)(,x)(BRANCH-NIL ,l) => (POP 2)) ;;; Pure stack motion: (peep (SWAP ,n)(SWAP ,n) => ) (peep (BLT-STK ,a ,b) (BLT-STK ,c ,d) => (>= a c) (>= (+ c d) a) (< (+ b d) 17) => (BLT-STK ,c ,(+ b d))) (peep (BLT-STK ,g ,n) (POP ,m) => (<= g m) => (POP ,(+ n m))) (peep (LOAD-STK ,k)(BLT-STK 1 ,n) => (> n k) => (POP ,k) (BLT-STK 1 ,(- n (+ k 1)))) (peep (LOAD-STK ,k)(BLT-STK 1 ,n) => (<= n k) => (POP ,n) (LOAD-STK ,(- k n))) (peep (LOAD-STK ,n)(BLAST ,(+ n 1)) => ) (peep (LOAD-STK ,n)(STORE-STK ,(+ n 1)) => 1) (peep (LOAD-STK 1) (BLT-STK 2 1) => (SWAP 1)) (peep (LOAD-STK 1) (BLT-STK 2 2) => (BLAST 2)) (peep (LOAD-STK 2) (BLT-STK 2 2) =>(BLT-STK 1 1)(SWAP 1)) (peep (LOAD-STK ,k)(BLT-STK ,g ,n) => (>= (+ 1 k) (+ g n)) => (BLT-STK ,(- g 1) ,n) (LOAD-STK ,(- k n))) (peep (POP ,a) (POP ,b) => (POP ,(+ a b))) (peep (STORE-STK ,a)(POP ,n) => (BLAST ,a)(POP ,(- n 1))) ;;; Stack motion interactions: (peep (forall x in0 out0 ns) (,x)(BLT-STK) => 2 1) (peep (forall x in0 out1 ns) (,x)(BLT-STK ,g ,n) => (BLT-STK ,(- g 1) ,n) 1) (peep (forall x in1 out1 ns) (,x)(BLT-STK) => 2 1) ;;; Screws up peephole termination proof by using extra stack: ;(peep (forall x in2 out1 ns) (,x)(BLT-STK ,g ,n) => (BLT-STK ,(+ g 1) ,n) 1) ;;; Screws up tail recursion: ;(peep (forall x in2 out1 ns) (BLT-STK ,g ,n)(,x) => 2 (BLT-STK ,(- g 1) ,n)) (peep (forall x in0 out1 nosides) (,x) (POP ,n) => (POP ,(- n 1))) (peep (forall x in1 out1 nosides) (,x) (POP) => 2) (peep (forall x in2 out1 nosides) (,x) (POP ,n) => (POP ,(+ n 1))) (peep (forall x in2 commutes) (SWAP 1)(,x) => 2) (peep (SWAP 1)(REVERSE-CONS) => (CONS)) (peep (SWAP 1)(CONS) => (REVERSE-CONS)) ;;; to speed fibb ? ;(peep (LOAD-IMM 0) (LOAD-GLO-CON ,v) (=) => (LOAD-GLO-CON ,v) (=0?)) ;;; Miscellaneous: (peep (LOAD-IMM 0) (=) => (=0?)) (peep (LOAD-GLO ,x)(CONTENTS) => (LOAD-GLO-CON ,x)) (peep (MAKE-BP-LOC ,n)(SET-CONTENTS) => (STORE-BP ,n)) (peep (LOAD-IMM ,x)(EQ?) => (null? x) => (NOT)) (peep (LOAD-IMM ,x)(NOT) => (LOAD-IMM ,(not x))) (peep (CONS) (CAR) => (BLT-STK 1 1)) (peep (REVERSE-CONS)(CDR) => (BLT-STK 1 1)) (peep (CONS) (CDR) => (POP 1)) (peep (REVERSE-CONS)(CAR) => (POP 1)) (peep (LOCATE-CAR)(CONTENTS) => (CAR)) (peep (LOCATE-CDR)(CONTENTS) => (CDR)) (peep (LOCATE-CAR)(SET-CONTENTS) => (SET-CAR)) (peep (LOCATE-CDR)(SET-CONTENTS) => (SET-CDR)) (destructure* (t1 t2) (emit-crunchers peephole instructions-with) (define peephole/1 t1) (define peephole/2 t2)) ;;; Output rewrites: (define-crunch peepout (blt-stk 1 1) => (blast 1)) (define-crunch peepout (load-imm ,n) => (tiny-number? n) => (load-imm-fix ,n)) (define-crunch peepout (load-imm ,x) => (null? x) => (load-reg nil)) (define-crunch peepout (load-imm #t) => (load-reg t)) (define-crunch peepout (load-code (code ,ivarmap ,instrs)) => (load-code (code ,ivarmap ,(peephole-optimize instrs)))) (destructure* (t1) (emit-crunchers peepout instructions-with) (define peepout/1 t1)) ;;; Main routine: ;;; Turn this on to watch the optimizer in action. (define peeptrace #f) (let ((output-rewrite (lambda (inguy) (let ((it (peepout/1 inguy))) (if (eq? it 'nochange) inguy (car it)))))) (define (peephole-optimize instruction-list) (when peeptrace (format #t "~&~A~%" instruction-list)) (iterate step ((left '()) (right instruction-list)) (cond ((null? right) ;; Finished. (let ((e (map! output-rewrite (reverse! left)))) (when peeptrace (format #t "~A~%" e)) e)) ((null? left) ;; Maybe move right: (let* ((i (car right)) (j (peephole/1 i)) (k (cdr right))) (if (eq? j 'nochange) (step (cons i left) k) (step left (append! j k))))) (else (let* ((i2 (car right)) (rr (cdr right)) (j (peephole/1 i2))) (if (eq? j 'nochange) (let ((att (peephole/2 (car left) i2))) (if (eq? att 'nochange) ;; Move right: (step (cons i2 left) rr) ;; Stay to left of new stuff: (block (when peeptrace (format #t "~&~A || ~A~%~A~%" (reverse left) right att)) (step (cdr left) (append! att rr))))) (step left (append! j rr))))))))) ;;; eof oaklisp-1.3.3.orig/src/world/locales.oak0000664000175000000620000001035207725515165017133 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Kevin J. Lang & Barak A. Pearlmutter ;;; Define locales (define-instance locale type '(variable-table frozen-symbols superiors macro-alist) (list object)) (add-method (initialize (locale variable-table frozen-symbols superiors macro-alist) self sups) (set! frozen-symbols '()) ;start out with nothing frozen here (set! variable-table (make-eq-hash-table)) (set! superiors sups) (set! macro-alist '()) self) (define-simple-print-method locale "Locale") (define-instance variable? settable-operation) (define-instance variable-here? settable-operation) (define-instance macro? settable-operation) (define-instance macro-here? settable-operation) (define-instance frozen? settable-operation) (define-instance frozen-here? settable-operation) (define-instance find-locale operation) (add-method (find-locale (locale superiors) self sym pred?) (if (pred? self sym) self (iterate aux ((locale-list superiors)) (if locale-list (or (find-locale (car locale-list) sym pred?) (aux (cdr locale-list))) nil)))) (add-method (variable? (locale) self sym) (let ((where (find-locale self sym variable-here?))) (if where (variable-here? where sym) nil))) (add-method ((setter variable?) (locale) self sym loci) (set! (variable-here? (or (find-locale self sym variable-here?) self) sym) loci)) (add-method (variable-here? (locale variable-table) self sym) (let ((x (present? variable-table sym))) (if x (cdr x) nil))) (add-method ((setter variable-here?) (locale variable-table) self sym loci) (cond ((null? loci) (set! (present? variable-table sym) nil)) (else (set! (present? variable-table sym) (if (eq? loci t) (%make-cell (make-undefined-variable-value sym)) loci))))) (add-method (macro? (locale superiors) self sym) ; (let ((loc (find-locale self sym macro-here?))) ; (if loc (macro-here? loc) nil)) (or (macro-here? self sym) (any? (lambda (loc) (macro? loc sym)) superiors)) ) (add-method ((setter macro?) (locale variable-table) self sym expander) (set! (macro-here? (or (find-locale self sym macro-here?) self) sym) expander)) (add-method (macro-here? (locale macro-alist) self sym) (let ((entry (assq sym macro-alist))) (if entry (cdr entry) nil))) (add-method ((setter macro-here?) (locale macro-alist) self sym expander) (when (variable? self sym) (warning "installing macro ~S in ~S where it is already a variable.~%" sym self)) (let ((entry (assq sym macro-alist))) (cond ((null? expander) (if entry (set! macro-alist (del! eq? entry macro-alist)) (warning "~S already isn't a macro in ~S.~%" sym self))) (entry (set! (cdr entry) expander)) (else (set! macro-alist (cons (cons sym expander) macro-alist))))) expander) (add-method (frozen? (locale) self sym) (frozen-here? (find-locale self sym variable-here?) sym)) (add-method ((setter frozen?) (locale) self sym new-phase) (set! (frozen-here? (find-locale self sym variable-here?) sym) new-phase)) (add-method (frozen-here? (locale frozen-symbols) self sym) (if (variable-here? self sym) (memq sym frozen-symbols) (error "Symbol ~A not installed in ~A so shouldn't be checked for FROZEN-HERE?." sym self))) (add-method ((setter frozen-here?) (locale frozen-symbols) self sym new-phase) (let ((old-phase (frozen-here? self sym))) (cond ((and new-phase (not old-phase)) (set! frozen-symbols (cons sym frozen-symbols))) ((and (not new-phase) old-phase) (set! frozen-symbols (delq sym frozen-symbols)))))) ;;; eof oaklisp-1.3.3.orig/src/world/multiproc.oak0000664000175000000620000003420007725515165017525 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; queue.oak (define (make-queue) (list '())) (define (enqueue obj q) (if (null? (car q)) (block (set! (car q) (list obj)) (set! (cdr q) (car q))) (block (set! (cdr (cdr q)) (list obj)) (set! (cdr q) (cdr (cdr q))))) (car q)) (define (dequeue q) (pop (car q))) (define (qappend q1 q2) (if (not (null? (car q2))) (block (set! (car q1) (append (car q1) (car q2))) (set! (cdr q1) (cdr q2)))) (car q1)) (define (qempty? q) (null? (car q))) ;;; potpourri.oak (set! #*fancy-references #t) (define-syntax (until test . body) `(labels ((fn (lambda () ,@body (if ,test #t (fn))))) (fn))) ;;; process.oak ;;; This is the initial process object class. The current-process ;;; object is stored in a register of the virtual machine for uniform ;;; access from the task code independant of which virtual machine ;;; (i.e. pthread) is running the task. ;;; The count of process id number is protected by a mutex, however, ;;; which requires that some process already be running. The first ;;; process is created before mutexes are defined, therefore, and so ;;; initialization of this class is redefined after the first one is ;;; made (as a warm boot action). See process2.oak for more code. (define-instance process type '(pid process-fluid-binding-list) (list object)) (define-instance process-id operation) (define-instance fluid-bindings settable-operation) (define-instance copy-fluid-bindings operation) (define trace-processes #t) (add-method (initialize (process pid process-fluid-binding-list) self) (when trace-processes (format #t "init: oak process descriptor~%")) (set! pid 0) (set! process-fluid-binding-list (map (lambda (z) (cons (car z) (cdr z))) fluid-binding-list)) self) (add-method (process-id (process pid) self) pid) (define (current-process) (%load-process)) (add-method (fluid-bindings (process process-fluid-binding-list) self) process-fluid-binding-list) (add-method ((setter fluid-bindings) (process process-fluid-binding-list) self new-fluid-binding-list) (set! process-fluid-binding-list new-fluid-binding-list)) (add-method (copy-fluid-bindings (process process-fluid-binding-list) self) (map (lambda (z) (cons (car z) (cdr z))) process-fluid-binding-list)) ;;; mutex.oak ;;; A solution to the critical section problem for multiple ;;; asynchronous processes, which must have shared access to a set of ;;; access flags and a contended turn value. ;;; This is supposed to be used to build higher-level access control ;;; objects, so that the amount of time spent using the lock to achive ;;; something is small and so processes will not have to be in busy ;;; waiting for very long. ;;; In practice, if we get this system running across multiple ;;; processors and have a situation that we don't expect to tkae very ;;; long to resolve, this may be adequate because the waiting process ;;; on another processor will not have to context switch itself out ;;; and back in because of being put on some waiting list. ;;; A process had better not release a mutex it has not acuired, for ;;; obvious reasons. ;;; This implementation uses a low-level %TEST-AND-SET-LOCATIVE opcode ;;; which is atomic. The mutex has a location that controls access to ;;; the critical section between an arbitrary number of asynchronous ;;; tasks, which is important in a future system with no reasonable ;;; bounds on the number of processes. ;;; %TEST-AND-SET-LOCATIVE is used to create a spin-lock, so mutexes ;;; spin lock too. Hence semaphores should be used when possible. (define-instance mutex type '(access-cons) (list object)) (define-instance acquire-mutex operation) (define-instance release-mutex operation) (add-method (initialize (mutex access-cons) self) (set! access-cons (cons nil nil)) self) (add-method (acquire-mutex (mutex access-cons) self) (until (%test-and-set-locative (car access-cons) #f #t))) (add-method (release-mutex (mutex access-cons) self) (set! (car access-cons) nil)) ;;; process2.oak ;; see process.oak for an explaination (define *pid-counter* 1) ;; the 0th process is not created with this counter (define *pid-counter-mutex* (make mutex)) (define (new-pid) (let ((newp nil)) (acquire-mutex *pid-counter-mutex*) (set! newp *pid-counter*) (set! *pid-counter* (+ *pid-counter* 1)) (release-mutex *pid-counter-mutex*) newp)) ;;; -------------------------------------------------- ;;; bootstrap initial process and redefine initialization ;;; redefine the initialization for processes after the first... ;;; redefine fluid operations ater the first... ;;; -------------------------------------------------- (define (setup-initial-process-object) (%store-process (make process)) (add-method (initialize (process pid process-fluid-binding-list) self) (set! pid (new-pid)) (set! process-fluid-binding-list (copy-fluid-bindings (current-process))) self) (spawn-heavyweight-threads)) ;;; XXX removed to make it boot!!! ;;; (add-warm-boot-action setup-initial-process-object) ;;-------------------------------------------------- ;;; testandset.oak ;;; Test-and-set in terms of mutexes. When the test (a predicate on ;;; the test-and-settable object) is true, the new value is assigned ;;; and returned, otherwise #f is returned. ;;; This is NOT the same as %test-and-set-car behavior, where the only ;;; predicate is (essentially) null? and the only non-null value is ;;; #t; here the predicate can be any function and the set value can ;;; be any non-nil value (so that success/failure can be distinguished ;;; when the set value is returned). (define-instance test-and-settable type '(ts-value) (list mutex)) (define-instance test-and-set operation) ; for debugging purposes only... (define-instance tsval operation) (add-method (initialize (test-and-settable ts-value) self) (set! ts-value '()) (^super mutex initialize self) self) (add-method (test-and-set (test-and-settable ts-value) self test new-value) (let ((set? #t)) (acquire-mutex self) (if (test ts-value) (set! ts-value new-value) (set! set? #f)) (release-mutex self) (if set? new-value #f))) (add-method (tsval (test-and-settable ts-value) self) ts-value) ;;; schedule.oak ;;; in order to avoid deadlock, the interrupt that invokes context ;;; switching must be disabled during scheduler interaction on a ;;; per-virtual-machine basis (between virtual machines, a mutex is ;;; used to preserve the critical section) ;;; at context switch time, the process register is fixed: ;;; ;;; * when a process is switched out, lwp gets the current process ;;; and saves it ;;; ;;; * when a process is switched in, start gets the saved process and ;;; sets it ;;; ;;; * when process-run-fn is called, it creates a new process and ;;; task and adds the block to the scheduler ;;; ;;; because the scheduler is acquired whenever these things are ;;; happening, it should not be possible for two different pthreads ;;; to think they are running the same process at any time (this ;;; would clearly be bad because then two threads of computation ;;; could acquire the same mutex at the same time) (define *scheduleQ* (make-queue)) (define *scheduleQ-mutex* (make mutex)) (define (acquire-scheduler) (%disable-alarms) (acquire-mutex *scheduleQ-mutex*)) (define (release-scheduler) (release-mutex *scheduleQ-mutex*) (%enable-alarms)) (define (lwp thunk) (acquire-scheduler) (enqueue (cons (%load-process) thunk) *scheduleQ*) (release-scheduler)) (define (start) (let ((next nil)) (acquire-scheduler) (if (qempty? *scheduleQ*) '() (set! next (dequeue *scheduleQ*))) (when next (%store-process (car next))) ;; fix process register and proceed (%reset-alarm-counter) (release-scheduler) (when next ((cdr next))))) ;;; pause causes a context switch. here is an easier-to-read version, ;;; it's expanded in order to make it atomic instead of just depending ;;; on lwp and start being atomic #| (define (pause) (call/cc (lambda (k) (lwp (lambda () (k #f))) (start)))) |# (define (pause) (let ((next nil) (pid (process-id (current-process)))) (acquire-scheduler) (when trace-processes (format #t "pause: acquired sched~%")) (call/cc (lambda (k) ;; (lwp (lambda () (k #f))) (enqueue (cons (%load-process) (lambda () (k #f))) *scheduleQ*) ;; (start) (if (qempty? *scheduleQ*) '() (set! next (dequeue *scheduleQ*))) (when next (%store-process (car next))) ;; fix process register and proceed (when trace-processes (format #t "pause: pre-reset alarm counter~%")) (%reset-alarm-counter) (release-scheduler) (when next ((cdr next))))))) ;;; no longer calls lwp because this must create a new process object (define (process-run-fn fn args) (acquire-scheduler) (enqueue (cons (make process) (lambda () (apply fn args) (start))) *scheduleQ*) (release-scheduler) nil) ;;; when heavyweight threads have nothing else to do, they have to be given ;;; a job that keeps them monitoring the scheduler. probably a sleep should ;;; be added to this (as another opcode which makes the VM sleep) to make ;;; busy waiting take less machine time (define (busy-work) (while #t (pause))) ;;; this is the function that bootstraps a new heavyweight process... ;;; start new hw threads as (%make-heavyweight-thread start-busy-work) ;;; THIS IS DONE AT WARM BOOT TIME AND SHOULD NOT BE DONE BY A USER (define (start-busy-work) (process-run-fn busy-work nil) (start)) ;;; -------------------------------------------------- ;;; Check to see if the user added a -pthreads option ;;; and launch some heavyweight threads accordingly. ;;; -------------------------------------------------- (define heavyweight-thread-count 1) (define (spawn-heavyweight-threads) (when (> heavyweight-thread-count 1) (format t "Spawning ~s pthreads.~%" heavyweight-thread-count) (dotimes (i (- heavyweight-thread-count 1)) (unless (%make-heavyweight-thread start-busy-work) (format t "Could not start heavyweight thread ~s.~%" (+ i 1)))))) ;;; semaphore.oak ;;; semaphores in terms of queues and mutexes. ;;; When processes wait on a semaphore, they are put in the queue as a ;;; pair of a process object and the closure representing it's ;;; continuing computation. This can then be moved directly to the ;;; scheduler when the semaphore is signaled. (define-instance semaphore type '(s-value s-Q) (list mutex)) (define-instance wait operation) (define-instance signal operation) (add-method (initialize (semaphore s-value s-Q) self) (set! s-value 0) (set! s-Q (make-queue)) (^super mutex initialize self) self) (add-method (wait (semaphore s-value s-Q) self) (acquire-mutex self) (set! s-value (- s-value 1)) (if (< s-value 0) ;; add to s-Q and block until woken (call/cc (lambda (c) ;; since context switching preserves current-process, ;; we should be able to just grab and go (enqueue (cons (current-process) (lambda () (c nil))) s-Q) (release-mutex self) (start))) (release-mutex self)) nil) ;;; WARNING: make sure that no other virtual process acquires a ;;; semaphore without first acquiring the scheduler! disabling alarms ;;; only prevents interrupts from occuring within the current pthread! ;;; (this should not be a problem since only these routines should ;;; acquire the semaphore) (add-method (signal (semaphore s-value s-Q) self) (acquire-scheduler) (acquire-mutex self) (set! s-value (+ s-value 1)) (when (<= s-value 0) ;; wake up the next blocked process (enqueue (dequeue s-Q) *scheduleQ*)) (release-mutex self) (release-scheduler) nil) ;;; future.oak ;;; futures: promises in a multitasking world (define-instance future-obj type '(flag val scheduled? dependantsQ sched-policy err-policy) (list forcible mutex)) (add-method (initialize (future-obj flag val scheduled? dependantsQ sched-policy err-policy) self oper) (set! scheduled? (make test-and-settable)) (set! dependantsQ (make-queue)) (set! sched-policy 'unused) (set! err-policy 'unused) (set! flag #f) (set! val oper) ;;(^super forcible initialize self) (^super mutex initialize self) self) (add-method (force (future-obj flag val scheduled? dependantsQ sched-policy err-policy) self) (acquire-mutex self) ; this mutex prevents dependants from enqueueing badly (if flag (block (release-mutex self) val) (call/cc (lambda (c) ;; suspend the current task into the destination queue (enqueue (cons (current-process);; process calling force (lambda () (let ((result (force self))) (c result)))) dependantsQ) (release-mutex self) ; now that we're enqueued, we're safe ;; someone claim responsibility for and initiate future computation (let ((schedule? (test-and-set scheduled? null? #t))) (when schedule? (process-run-fn (lambda () (let ((newval (val))) (acquire-mutex self) (set! flag #t) (set! val newval) (release-mutex self) ;; at this point no more people will ;; be trying to add themselves... (acquire-scheduler) (qappend *scheduleQ* dependantsQ) (release-scheduler))) nil))) (start))))) (define-syntax delay (lambda (form) `(make future-obj (lambda () . ,(cdr form))))) (define-syntax future (lambda (form) `(let ((foosym (make future-obj (lambda () . ,(cdr form))))) (process-run-fn force (list foosym)) foosym))) oaklisp-1.3.3.orig/src/world/promise.oak0000664000175000000620000000777007725515165017201 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1989 Barak A. Pearlmutter & Kevin J. Lang ;;; Promises. There is an abstract type, FORCIBLE, which the really ;;; low level system code checks for when trapping out. Things that ;;; actually delay their computation, or do it concurrently, or read ;;; it off disk, or whatever, should inherit from it. ;; Moved back much earlier, so system code can add methods for forcible. ;;(define-instance forcible type '() '()) (define-instance force operation) (add-method (force (object) self) self) (add-method (force (forcible) self) (bind ((#*forcible-print-magic #f)) (error "Attempt to force ~S, which has no FORCE method." self))) ;;; This switch determines whether forcible things force themselves before ;;; printing. ;;; Possible values are: ;;; ;;; value style of (DELAY 'FOO) ;;; ;;; #F # ;;; INDICATE #[DELAY FOO 3462] ;;; TRANSPARENT FOO (set! #*forcible-print-magic 'transparent) (add-method (print (forcible) self s) (let ((f #*forcible-print-magic)) (cond ((eq? f 'transparent) (print (force self) s)) ((eq? f '#f) (format s "#" self)) ((eq? f 'indicate) (format s "#[DELAY ~S ~!]" (force self) self)) (else (error "Unknow FORCIBLE-PRINT-MAGIC option ~S." f))))) (add-method (print-list-end (forcible) self . args) (if #*forcible-print-magic (print-list-end (force self) . args) (^super object print-list-end self . args))) ;;; Simple R3RS style promises, except they get automatically forced. (define-instance promise type '(flag val) (list forcible object)) (add-method (initialize (promise flag val) self oper) (set! flag #f) (set! val oper) self) (add-method (force (promise flag val) self) (if flag val (let ((newval (val))) ;; Critical section; would be a good idea to disable interrupts. (set! flag #t) (set! val newval)))) (define-syntax delay (lambda (form) `(make promise (lambda () . ,(cdr form))))) ;;; This switch determines whether the error system forces things ;;; and retries operations that fail due to something being a forcible ;;; object. Time to turn it on... (set! forcible-magic #t) ;;; When multiple dispatch is up, this should dispatch on the second arg ;;; symetrically. (add-method (eqv? (forcible) self other) (eqv? (force self) other)) #|| ;;; NOTE: Neither of these are actually activated, because IS-A? is really ;;; critical, and we don't want to actually slow down the system. Load one ;;; if you actually want to use promises and want things that do TYPECASE ;;; to work on them. All the type predicates use IS-A? (see predicates.oak) ;;; so this should make them automatically force delays too. On the other ;;; hand, the type predicates could be switched to use dispatch without ;;; warning upon suitable benchmarks. ;;; A patch to do similar things to the system predicates is commented out ;;; in predicates.oak ;;; Not modular, but maybe faster: (define (is-a? obj typ) (iterate is-a? ((obj obj)) (let ((typ2 (get-type obj))) (if (and forcible-magic (subtype typ2 forcible)) (is-a? (force obj) typ) (subtype? typ2 typ))))) ;;; Modular, but maybe slower: (add-method (is-a? (forcible) self typ) (if forcible-magic (is-a? (force self) typ) (^super object is-a? self typ))) ||# ;;; eof oaklisp-1.3.3.orig/src/world/cold.oak0000664000175000000620000000255607725515165016441 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Barak A. Pearlmutter and Kevin J. Lang ;;; Define both input and output streams that might work during the cold ;;; load process, so we can have a gander at error messages and maybe poke ;;; about. (let ((cold-load-input-stream (make type '() (list input-stream object))) (cold-load-output-stream (make type '() (list output-stream object)))) (add-method (really-read-char (cold-load-input-stream) self) (%read-char)) (add-method (write-char (cold-load-output-stream) self char) (%write-char char)) (set! standard-input (make cold-load-input-stream)) (set! standard-output (make cold-load-output-stream))) ;;; eof oaklisp-1.3.3.orig/src/world/exit.oak0000664000175000000620000000346607725515165016472 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Kevin J. Lang & Barak A. Pearlmutter (let ((exit-aux (lambda (args) (destructure (status . format-args) args (flush standard-error) (if (null? format-args) (if (= 0 status) (format standard-output "~&Oaklisp stopped itself...~%") (format standard-output "~&Oaklisp stopped itself (status ~D)...~%" status)) (apply format standard-output format-args)) (flush standard-output) (flush standard-error) (cond ((= 0 status) ((%halt 0))) ((= 1 status) ((%halt 1))) ((= 2 status) ((%halt 2))) ((= 3 status) ((%halt 3))) ((= 4 status) ((%halt 4))) ((= 5 status) ((%halt 5))) ((= 6 status) ((%halt 6))) ((= 7 status) ((%halt 7))) ((= 8 status) ((%halt 8))) ((= 9 status) ((%halt 9))) ((= 10 status) ((%halt 10))) (else (format standard-output "(exit status ~D out of range)~%" status) (flush standard-output) ((%halt 10)))))))) (define (exit . args) (cond ((= 0 (rest-length args)) (listify-args exit-aux #*debug-level . args)) (else (listify-args exit-aux . args))))) ;;; eof oaklisp-1.3.3.orig/src/world/string-stream.oak0000664000175000000620000000366407725515165020320 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Barak A. Pearlmutter & Kevin J. Lang ;;; Magic streams that don't really do i/o, but save or get their ;;; stuff from strings. Used mostly for (FORMAT NIL ...) and some ;;; Common Lisp like things. (define-instance string-output-stream type '(accumulated) (list output-stream object)) (add-method (initialize (string-output-stream accumulated) self) (set! accumulated '()) self) (add-method (write-char (string-output-stream accumulated) self char) (set! accumulated (cons char accumulated)) char) (add-method (#^string (string-output-stream accumulated) self) (#^string (reverse accumulated))) ;;; Calling this a STRING-INPUT-STREAM is a misnomer; actually, it can get ;;; its input from any sequence. (define-instance string-input-stream type '(the-string index len) (list input-stream stream object)) (add-method (initialize (string-input-stream the-string index len) self stuff) (set! the-string stuff) (set! index 0) (set! len (length the-string)) (^super input-stream initialize self)) (add-method (really-read-char (string-input-stream the-string index len) self) (if (= index len) the-eof-token (block0 (nth the-string index) (set! index (+ index 1))))) ;;; eof oaklisp-1.3.3.orig/src/world/fasl.oak0000664000175000000620000001063307725515165016440 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1986 Barak A. Pearlmutter & Kevin J. Lang ;;; Define the stuff to link in fasl format code segments, and to load files. (define-instance %ivar-map locatable-operation) (add-method ((locater %ivar-map) (%code-vector ivar-map) self) (make-locative ivar-map)) ;;; Codes used in the resolution list to mark different clause types. (define-constant variable-key 0) (define-constant code-key 1) (define-constant constant-key 2) (define (link-code-segment locale segment) (let ((already-warned #f)) (iterate aux0 ((inputs segment) (outputs '()) (code-resolution-lists '())) (cond ((null? inputs) (when already-warned (format #t ".~%")) (let ((outputs (reverse outputs))) (dolist (crl (reverse code-resolution-lists) (car outputs)) (dolist (clause crl) (set! (contents (cdr clause)) (nth outputs (car clause))))))) (else (destructure ((resolution-list ('0 '0 . code)) . #t) inputs (let* ((instruction-count (length code)) (word-count (quotient (+ instruction-count 1) 2)) (v (make %code-vector word-count))) (iterate aux ((c code) (i 0)) (cond ((not (null? c)) ;;(destructure (xi xj . rest) c ) (let* ((xi (car c)) (xj (if (null? (cdr c)) 0 (cadr c))) (rest (if (null? (cdr c)) nil (cddr c)))) (set! (%vref v i) (if (%big-endian?) (%crunch (bit-or (ash-left xi 14) (ash-right xj 2)) (bit-and xj #x3)) ;(bit-or (ash-left xi 14) xj) (%crunch (bit-or (ash-left xj 14) (ash-right xi 2)) (bit-and xi #x3)) ;(bit-or xi (ash-left xj 14)) )) (aux rest (+ i 1)))) ;;((not (null? c)) ;; (set! (nth v i) (car c)) ;; (aux (cdr c) (+ i 1))) (else (iterate aux ((resolution-list resolution-list) (code-number-to-locs-alist '())) (cond ((null? resolution-list) (aux0 (cdr inputs) (cons v outputs) (cons code-number-to-locs-alist code-resolution-lists))) (else (let ((clause (car resolution-list))) (destructure (which where what) clause (cond ((eq? where 0) (cond ((eq? which constant-key) (set! (%ivar-map v) what) (aux (cdr resolution-list) code-number-to-locs-alist)) (else (error "Bad FASL patch clause ~S, only constants may be placed in the IVAR-MAP slot." clause)))) (else (let ((where-loc (make-locative (%vref v (- (quotient where 2) 1))))) (cond ((eq? which constant-key) (set! (contents where-loc) what) (aux (cdr resolution-list) code-number-to-locs-alist)) ((eq? which variable-key) (set! (contents where-loc) (or (variable? locale what) (let* ((y (%make-cell (make-undefined-variable-value what)))) (cond ((not already-warned) (format #t "~&Variables installed in ~S: ~S" locale what) (set! already-warned #t)) (else (format #t ", ~S" what))) (set! (variable? locale what) y) y))) (aux (cdr resolution-list) code-number-to-locs-alist)) ((eq? which code-key) (aux (cdr resolution-list) (cons (cons what where-loc) code-number-to-locs-alist))) (else (error "Weird FASL resolution clause ~S.~%" clause))))))))))))))))))))) (define (load-code-segment locale segment) (bind ((#*current-locale locale)) ((%install-method-with-env object (make operation) (link-code-segment locale segment) %empty-environment) ;; Code segments don't have CHECK-NARGS, so the operation isn't ;; going to get popped, so we don't pass anything extra: ;'loaded )) 'loaded) ;;; eof oaklisp-1.3.3.orig/src/world/error.oak0000664000175000000620000000245107725515165016643 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1987 Barak A. Pearlmutter and Kevin J. Lang ;;; This file defines a simple interface to the error system. Like Common ;;; Lisp, use ERROR if it's fatal and CERROR if it could be corrected and ;;; proceded from. ;;; This holds how many recursive debuggers we're inside. (set! #*debug-level 0) (define (warning format-string . format-args) (format standard-error "~&Warning: ") (format standard-error format-string . format-args)) (define (poison . args) (listify-args (lambda (args) (error "The poison function was called with args ~S." args)) . args)) ;;; eof oaklisp-1.3.3.orig/src/world/nargs.oak0000664000175000000620000000247507725515165016632 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988 Barak A. Pearlmutter & Kevin J. Lang ;;; Some entry points. (let ((bad-nargs (lambda (stuff) (destructure (extra-okay requested op . args) stuff (signal (if extra-okay nargs-gte-error nargs-exact-error) op args requested))))) (define (incorrect-nargs requested op . args) (listify-args bad-nargs #f requested op . args)) (define (incorrect-nargs-gte minimum-requested op . args) (listify-args bad-nargs #t minimum-requested op . args))) (set! (nth %arged-tag-trap-table 24) incorrect-nargs) (set! (nth %arged-tag-trap-table 25) incorrect-nargs-gte) ;;; eof oaklisp-1.3.3.orig/src/emulator/0002775000175000000620000000000011036654362015510 5ustar barakstaffoaklisp-1.3.3.orig/src/emulator/xmalloc.c0000664000175000000620000001170411036404255017306 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #define _REENTRANT #include #include #include #undef NDEBUG #include #include "config.h" #include "data.h" #include "xmalloc.h" bool isaligned(void *x) { return ((unsigned long)x & 0x3) == 0; } void * xmalloc(size_t size) { /* replacement for ansi-library-malloc */ void *ptr = malloc(size); if (ptr) { /* #ifndef UNALIGNED_MALLOC assert(isaligned(ptr)); #endif */ return ptr; } else { fprintf(stderr, "ERROR(xmalloc): Unable to allocate %lu bytes.\n", (unsigned long)size); exit(EXIT_FAILURE); return 0; } } void alloc_space(space_t * pspace, size_t size_requested) { void *ptr; /* size_requested measures references */ #ifdef UNALIGNED_MALLOC void *ptr = xmalloc(sizeof(ref_t) * (size_requested + 1)); pspace->displacement = (size_t) ((unsigned long)ptr & (3ul)); pspace->start = (ref_t *) (((unsigned long)ptr + 3) & ~3ul); /* Explanation: * displacement address correction * 0 (mod 4) + 0, which is good, to preserve higher alignment * 1 (mod 4) + 3 * 2 (mod 4) + 2 * 3 (mod 4) + 1 * wastes a maximum of 4 bytes */ #else /* UNALIGNED_MALLOC */ ptr = xmalloc(sizeof(ref_t) * size_requested); pspace->start = (ref_t *) ptr; #endif pspace->size = size_requested; pspace->end = pspace->start + size_requested; } void free_space(space_t * pspace) { void *ptr; #ifdef UNALIGNED_MALLOC if (pspace.displacement) { /* reverse alignment correction */ ptr = (void *)((unsigned long)pspace->start - 4 + pspace->displacement); } else { ptr = (void *)pspace->start; } #else /* UNALIGNED_MALLOC */ ptr = (void *)pspace->start; #endif assert(ptr != 0); free(ptr); pspace->start = pspace->end = 0; pspace->size = 0; #ifdef UNALIGNED_MALLOC pspace->displacement = 0; #endif } /*This is called by gc. Can't acquire alloc lock from gc since inversion occurs with macro ALLOC_SS but no need*/ void realloc_space(space_t * pspace, size_t size_requested) { void *ptr; void *newptr; #ifdef UNALIGNED_MALLOC if (pspace->displacement) { /* reverse alignment correction */ ptr = (void *)((unsigned long)pspace->start - 4 + pspace->displacement); newptr = realloc(ptr, sizeof(ref_t) * (size_requested + 1)); } else { ptr = (void *)pspace->start; newptr = realloc(ptr, sizeof(ref_t) * (size_requested)); /* we need not waste another 4 bytes here */ } #else /* UNALIGNED_MALLOC */ ptr = (void *)pspace->start; newptr = realloc(ptr, sizeof(ref_t) * (size_requested)); #endif if (ptr) { pspace->end = pspace->start + size_requested; pspace->size = size_requested; } else { fprintf(stderr, "(ERROR(realloc_space): Unable to reallocate %lu bytes.\n", (unsigned long)size_requested); exit(EXIT_FAILURE); } } void oak_c_string_fill(ref_t * oakstr, char *cstring, int len) { int i = 0; while (i + 2 < len) { unsigned long temp = *oakstr; cstring[i + 0] = 0xff & (temp >> 2); cstring[i + 1] = 0xff & (temp >> (8 + 2)); cstring[i + 2] = 0xff & (temp >> (16 + 2)); oakstr++; i += 3; } if (i + 1 < len) { unsigned long temp = *oakstr; cstring[i + 0] = 0xff & (temp >> 2); cstring[i + 1] = 0xff & (temp >> (8 + 2)); oakstr++; i += 2; } else if (i < len) { unsigned long temp = *oakstr; cstring[i + 0] = 0xff & (temp >> 2); /* oakstr++; */ i++; } cstring[i + 0] = '\0'; } char * oak_c_string(ref_t * oakstr, int len) { /* Converts an Oaklisp string, given by a pointer to its start and a length, to an equivalent C-string. The storage allocated by this routine must be free()-ed. */ char *const cstring = xmalloc(len + 1); oak_c_string_fill(oakstr, cstring, len); return cstring; } oaklisp-1.3.3.orig/src/emulator/loop.h0000664000175000000620000000222611036404255016624 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #ifndef _LOOP_H_INCLUDED #define _LOOP_H_INCLUDED #include "data.h" extern void loop(ref_t); #endif oaklisp-1.3.3.orig/src/emulator/config.h0000664000175000000620000000633111036651016017120 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ /* * Some configuration parameters explained: * ======================================== * * ASHR2 * Must do arithmetic right shift on its argument. * Use ((x)/4) if your compiler generates logical shifts for * ((x)>>2) * * * UNALIGNED_MALLOC * Defined if malloc() might return a pointer that is not longword * aligned, i.e. whose low two bits might not be 0. * * * THREADS * If defined, heavyweight OS pthreads are enabled. * */ #ifndef _CONFIG_H_INCLUDED #define _CONFIG_H_INCLUDED #if defined(linux) && defined (__GNUC__) /*** Linux with GCC ***/ #include #if (__WORDSIZE != 32) #error word size must be 32 bits #endif #define ASHR2(x) ((x)>>2) #define HAVE_GETRUSAGE //#define THREADS #ifdef THREADS #define MAX_THREAD_COUNT 200 #endif #include /* for the chdir() and isatty() functions */ #elif defined(__arm__) && defined(linux) /*** Linux on Arm target ***/ #define WORDSIZE 32 #define HAVE_LONG_LONG #define ASHR2(x) ((x)>>2) #define BYTE_GENDER little_endian #define HAVE_GETRUSAGE #include /* for the chdir() and isatty() functions */ #elif defined(__sparc__) && defined(linux) /*** SPARC Linux target ***/ #define WORDSIZE 32 #define HAVE_LONG_LONG #define ASHR2(x) ((x)>>2) #define BYTE_GENDER big_endian #define HAVE_GETRUSAGE #elif defined(__mc68000__) && defined(linux) /*** Motorola 68k Linux target ***/ #define WORDSIZE 32 #define HAVE_LONG_LONG #define ASHR2(x) ((x)>>2) #define BYTE_GENDER big_endian #define HAVE_GETRUSAGE else /*** no machine specified ***/ #error must edit config.h #endif /* Speed parameters */ /* Turn off most runtime debugging features that slow down the system. */ // #define FAST /* Toggle specific optimizations. */ /* Activate operation-method association list move-to-front. */ #ifndef THREADS #define OP_METH_ALIST_MTF #endif /* Activate operation-type method cache. */ #ifndef THREADS #define OP_TYPE_METH_CACHE #endif #ifdef USING_HORRIBLE_MS_WINDOWS typedef unsigned long u_int32_t; typedef unsigned short u_int16_t; typedef int int32_t; typedef unsigned char u_int8_t; typedef signed char int8_t; typedef short int16_t; #endif // USING_HORRIBLE_MS_WINDOWS #endif oaklisp-1.3.3.orig/src/emulator/instruction-table.oak0000664000175000000620000000365011036617654021657 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Copyright (C) 1988-2008 Kevin J. Lang & Barak A. Pearlmutter ;;; Dump a table of all the instructions in a format suitable for ;;; compilation into the emulator. (let ((aux (lambda (s instr i) (format s " \"~S\"," instr) (if (= (modulo i 10) 0) (format s " /* ~D */~%" i) (format s "~%"))))) (define (dump-instruction-table f) (let ((t0 (make simple-vector %argless-instructions)) (t1 (make simple-vector %arged-instructions))) (dotimes (i %argless-instructions) (set! (nth t0 i) (#^symbol (format #f "ILLEGAL-ARGLESS-~d" i)))) (dotimes (i %arged-instructions) (set! (nth t1 i) (#^symbol (format #f "ILLEGAL-ARGED-~d" i)))) (dolist (x (#^list-type opcode-descriptor-hash-table)) (destructure* (instr opcode argfield . #t) x (cond ((= opcode 0) (set! (nth t0 argfield) instr)) (else (set! (nth t1 opcode) instr))))) (with-open-file (s f out) (format s "// Automatically generated by instruction-table.oak~%~%") (format s "char *argless_instr_name[] = {~%") (dotimes (i %argless-instructions) (aux s (nth t0 i) i)) (format s "};~%~%") (format s "char *instr_name[] = {~%") (dotimes (i %arged-instructions) (aux s (nth t1 i) i)) (format s "};~%"))))) oaklisp-1.3.3.orig/src/emulator/timers.c0000664000175000000620000000615411036404255017155 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #define _REENTRANT #include #include #include #include #include #include #include "config.h" #include "timers.h" #if defined(HAVE_GETTICKCOUNT) unsigned long get_real_time(void) { return (unsigned long)GetTickCount(); } unsigned long get_user_time(void) { return get_real_time(); } #elif defined(HAVE_GETRUSAGE) #include #if (defined(__hpux) && !defined(_HPUX_SOURCE)) #define _HPUX_SOURCE #endif #if (defined(sun) && defined(__SVR4)) #include "/usr/ucbinclude/sys/rusage.h" #include "/usr/ucbinclude/sys/resource.h" #else #include #endif #ifdef __hpux #include #define getrusage(a, b) syscall(SYS_getrusage, (a), (b)) #endif unsigned long get_real_time(void) { unsigned long result; struct timeval tnow; if (0 != gettimeofday(&tnow, 0)) { fprintf(stderr, "ERROR (Time): Unable to obtain time of day; %s\n", strerror(errno)); exit(EXIT_FAILURE); } else { result = tnow.tv_sec * 1000 + tnow.tv_usec / 1000; return result; } } unsigned long get_user_time(void) { struct rusage rusage; unsigned long result; if (0 != getrusage(RUSAGE_SELF, &rusage)) { fprintf(stderr, "ERROR (Time): Unable to getrusage(); %s\n", strerror(errno)); exit(EXIT_FAILURE); } else { result = rusage.ru_utime.tv_sec * 1000 + rusage.ru_utime.tv_usec / 1000; return result; } } #else /* plain ansi-libraries */ unsigned long get_real_time(void) { #ifdef __GLIBC_HAVE_LONG_LONG unsigned long long temp; temp = (unsigned long long)clock() * (1000ull / CLOCKS_PER_SEC); #else long temp; temp = (clock() * 1000) / (CLOCKS_PER_SEC); #endif /* caution: the clock() function on some systems with a high frequency clock (e.g. transputers ) give values modulo a not too big time span, so a wrap around can occur between to calls, which leads to odd results */ return (unsigned long)temp; } unsigned long get_user_time(void) { return get_real_time(); } #endif oaklisp-1.3.3.orig/src/emulator/weak.c0000664000175000000620000001217011036404255016574 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #define _REENTRANT #include #include #include #include "config.h" #include "data.h" #include "xmalloc.h" #include "gc.h" #include "weak.h" /* * Weak pointers are done with a simple table that goes from weak * pointers to objects, and a hash table that goes from objects to * their weak pointers. * In the future, this will be modified to keep separate hash tables * for the different areas, so that objects in spatic space need not * be rehashed. * Plus another one for unboxed values like fixnums. */ const int wp_table_size = 3000; const int wp_hashtable_size = 3017; ref_t *wp_table; /* wp -> ref */ int wp_index = 0; /* number of entries in wp_table */ /* A hash table from references to their weak pointers. This hash * table is not saved in dumped worlds, and is rebuilt from scratch * after each GC and upon booting a new world. * Structure of this hash table: * Keys are references themselves, smashed about and xored if deemed * necessary. * Sequential rehash, single probe. */ typedef struct { ref_t obj; ref_t wp; } wp_hashtable_entry; wp_hashtable_entry *wp_hashtable; /* The following magic number is floor( 2^32 * (sqrt(5)-1)/2 ). */ #define wp_key(r) ((unsigned long) 0x9E3779BB*(r)) /* >>10, == 2654435771L */ void init_weakpointer_tables(void) { wp_table = (ref_t *) xmalloc((wp_table_size + 1) * sizeof(ref_t)); wp_hashtable = (wp_hashtable_entry *) xmalloc(sizeof(wp_hashtable_entry) * wp_hashtable_size); } /* Register r as having weak pointer wp. */ static void enter_wp(ref_t r, ref_t wp) { long i = wp_key(r) % wp_hashtable_size; while (1) /* forever */ if (wp_hashtable[i].obj == e_false) { wp_hashtable[i].obj = r; wp_hashtable[i].wp = wp; return; } else if (++i == wp_hashtable_size) i = 0; } /* Rebuild the weak pointer hash table from the information in the table that takes weak pointers to objects. */ void rebuild_wp_hashtable(void) { long i; for (i = 0; i < wp_hashtable_size; i++) wp_hashtable[i].obj = e_false; for (i = 0; i < wp_index; i++) if (wp_table[1 + i] != e_false) enter_wp(wp_table[1 + i], INT_TO_REF(i)); } /* Return weak pointer associated with obj, making a new one if necessary. */ ref_t ref_to_wp(ref_t r) { long i; ref_t temp; if (r == e_false) return INT_TO_REF(-1); i = wp_key(r) % wp_hashtable_size; while (1) /* forever */ { temp = wp_hashtable[i].obj; if (temp == r) { return wp_hashtable[i].wp; } else if (temp == e_false) { /* Make a new weak pointer, installing it in both tables: */ wp_hashtable[i].obj = wp_table[1 + wp_index] = r; return wp_hashtable[i].wp = INT_TO_REF(wp_index++); } else if (++i == wp_hashtable_size) { i = 0; } } } #if 0 /* commented out */ #include void wp_hashtable_distribution(void) { long i; for (i = 0; i < wp_hashtable_size; i++) { ref r = wp_hashtable[i].obj; if (r == e_false) (void)putchar('.'); else { unsigned long j = wp_key(r) % wp_hastable_size; long dist = i - j; if (dist < 0) dist += wp_hastable_size; if (dist < 1 + '9' - '0') (void)putchar((char)('0' + dist)); else if (dist < 1 + 'Z' - 'A' + 1 + '9' - '0') (void)putchar((char)('A' + dist - (1 + '9' - '0'))); else (void)putchar('*'); } fflush(stdout); } } #endif /* commented out */ unsigned long post_gc_wp(void) { /* Scan the weak pointer table. When a reference to old space is found, check if the location has a forwarding pointer. If so, update it; if not, discard it. */ long i; unsigned long discard_count = 0; for (i = 0; i < wp_index; i++) { ref_t r = wp_table[1 + i], *p; if ((r & PTR_MASK) && (p = ANY_TO_PTR(r), OLD_PTR(p))) { ref_t r1 = *p; if (TAG_IS(r1, LOC_TAG) && NEW_PTR(LOC_TO_PTR(r1))) { wp_table[1 + i] = TAG_IS(r, LOC_TAG) ? r1 : r1 | PTR_TAG; } else { wp_table[1 + i] = e_false; discard_count += 1; } } } rebuild_wp_hashtable(); return discard_count; } oaklisp-1.3.3.orig/src/emulator/worldio.c0000664000175000000620000002246711036404255017336 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /*********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-2000. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * ***********************************************************************/ #define _REENTRANT #include #include #include #include #include #include "config.h" #include "data.h" #include "xmalloc.h" #include "worldio.h" #include "weak.h" /* * Format of Oaklisp world image: * * UNUSED: * UNUSED: * * * * * * * */ bool input_is_binary; /* These are for making the world zero-based and contiguous in dumps. */ static ref_t contig(ref_t r, bool just_new) { ref_t *p = ANY_TO_PTR(r); if (just_new) if (NEW_PTR(p)) return ((ref_t) (p - new_space.start) << 2) | (r & 3); else printf("Non-new pointer %lu found.\n", (unsigned long)r); else if (SPATIC_PTR(p)) return ((ref_t) (p - spatic.start) << 2) | (r & 3); else if (NEW_PTR(p)) return ((ref_t) (p - new_space.start + spatic.size) << 2) | (r & 3); else printf("Non-new or spatic pointer %lu found.\n", (unsigned long)r); return r; } #define contigify(r) ((r)&0x2 ? contig((r),just_new) : (r)) #define CONTIGIFY(v) { if ((v)&2) (v) = contig((v),just_new); } static ref_t read_ref(FILE * d) { /* Read a reference from a file: */ int c; ref_t a = 0; /* It's easy to read a reference from a binary file. */ if (input_is_binary) { fread((void *)&a, sizeof(ref_t), 1, d); return a; } else { if (__BYTE_ORDER == __LITTLE_ENDIAN) { while (isspace(c = getc(d))) if (c == EOF) { printf("Apparently truncated cold load file!\n"); exit(EXIT_FAILURE); } { bool swapem = c == '^'; if (swapem) if ((c = getc(d)) == EOF) { printf("Apparently truncated cold load file!\n"); exit(EXIT_FAILURE); } while (isxdigit(c)) { a = a << 4; if (c <= '9') a |= ((ref_t) c - '0'); else if (c <= 'Z') a |= ((ref_t) c - 'A' + 10); else a |= ((ref_t) c - 'a' + 10); c = getc(d); } if (c == '^') ungetc(c, d); if (swapem) a = (a << 16 | a >> 16); } return a; } else { /* __BYTE_ORDER == __BIG_ENDIAN */ while (isspace(c = getc(d)) || c == '^') if (c == EOF) { printf("Apparently truncated cold load file!\n"); exit(EXIT_FAILURE); } while (isxdigit(c)) { a = a << 4; if (c <= '9') a |= ((ref_t) c - '0'); else if (c <= 'Z') a |= ((ref_t) c - 'A' + 10); else a |= ((ref_t) c - 'a' + 10); c = getc(d); } return a; } /* __BYTE_ORDER */ } /* input_is_binary */ } #define REFBUFSIZ 256 ref_t refbuf[REFBUFSIZ]; static void dump_binary_world(bool just_new) { FILE *wfp = 0; ref_t *memptr; ref_t theref; /* CAUTION: STACK SPACE!!! */ int imod = 0; unsigned long worlsiz = free_point - new_space.start; unsigned long DUMMY = 0; fprintf(stderr, "Dumping in binary.\n"); wfp = fopen(dump_file_name, WRITE_BINARY_MODE); if (!wfp) { fprintf(stderr, "error opening \"%s\"\n", dump_file_name); exit(EXIT_FAILURE); } if (!just_new) worlsiz += spatic.size; putc('\002', wfp); putc('\002', wfp); putc('\002', wfp); putc('\002', wfp); /* Header information. */ fwrite((const void *)&DUMMY, sizeof(ref_t), 1, wfp); fwrite((const void *)&DUMMY, sizeof(ref_t), 1, wfp); theref = contigify(e_boot_code); fwrite((const void *)&theref, sizeof(ref_t), 1, wfp); fwrite((const void *)&worlsiz, sizeof(ref_t), 1, wfp); /* Dump the heap. */ /* Maybe dump spatic space. */ if (!just_new) for (memptr = spatic.start; memptr < spatic.end; memptr++) { theref = *memptr; CONTIGIFY(theref); refbuf[imod++] = theref; if (imod == REFBUFSIZ) { fwrite((const void *)refbuf, sizeof(ref_t), imod, wfp); imod = 0; } } /* Dump new space. */ for (memptr = new_space.start; memptr < free_point; memptr++) { theref = *memptr; CONTIGIFY(theref); refbuf[imod++] = theref; if (imod == REFBUFSIZ) { fwrite((const void *)refbuf, sizeof(ref_t), imod, wfp); imod = 0; } } if (imod != 0) fwrite((const void *)refbuf, sizeof(ref_t), imod, wfp); /* Weak pointer table. */ theref = (ref_t) wp_index; fwrite((const void *)&theref, sizeof(ref_t), 1, wfp); for (imod = 0; imod < wp_index; imod++) { theref = wp_table[1 + imod]; CONTIGIFY(theref); fwrite((const void *)&theref, sizeof(ref_t), 1, wfp); } fclose(wfp); } static void dump_ascii_world(bool just_new) { ref_t *memptr, theref; long i; int eighter = 0; char *control_string = (dump_base == 10 ? "%ld " : "%lx "); FILE *wfp = 0; fprintf(stderr, "Dumping in ascii.\n"); wfp = fopen(dump_file_name, WRITE_MODE); if (!wfp) { fprintf(stderr, "error: cannot open \"%s\"\n", dump_file_name); exit(EXIT_FAILURE); } fprintf(wfp, control_string, 0 /*val_stk_size */ ); fprintf(wfp, control_string, 0 /*cxt_stk_size */ ); fprintf(wfp, control_string, contigify(e_boot_code)); fprintf(wfp, control_string, free_point - new_space.start + (just_new ? 0 : spatic.size)); /* Maybe dump spatic space. */ if (!just_new) for (memptr = spatic.start; memptr < spatic.end; memptr++) { if (eighter == 0) fprintf(wfp, "\n"); theref = *memptr; CONTIGIFY(theref); fprintf(wfp, control_string, theref); eighter = (eighter + 1) % 8; } eighter = 0; for (memptr = new_space.start; memptr < free_point; memptr++) { if (eighter == 0) fprintf(wfp, "\n"); theref = *memptr; CONTIGIFY(theref); fprintf(wfp, control_string, theref); eighter = (eighter + 1) % 8; } fprintf(wfp, "\n"); /* Write the weak pointer table. */ fprintf(wfp, control_string, wp_index); eighter = 0; for (i = 0; i < wp_index; i++) { if (eighter == 0) fprintf(wfp, "\n"); theref = wp_table[1 + i]; CONTIGIFY(theref); fprintf(wfp, control_string, theref); eighter = (eighter + 1) % 8; } fclose(wfp); } void dump_world(bool just_new) { fprintf(stderr, "About to dump the oaklisp world.\n"); if (dump_base == 2) dump_binary_world(just_new); else dump_ascii_world(just_new); } static void reoffset(ref_t baseAddr, ref_t * start, long count) { long index; ref_t *next; next = start; for (index = 0; index < count; index++) { if (*next & 2) *next += baseAddr; next++; } } void read_world(char *str) { FILE *d; int magichar; if ((d = fopen(str, READ_BINARY_MODE)) == 0) { printf("Can't open \"%s\".\n", str); exit(EXIT_FAILURE); } magichar = getc(d); if (magichar == (int)'\002') { getc(d); getc(d); getc(d); input_is_binary = 1; } else { ungetc(magichar, d); input_is_binary = 0; if (__BYTE_ORDER == __LITTLE_ENDIAN) printf("Little Endian.\n"); else printf("Big Endian.\n"); } /* Obsolescent: read val_space_size and cxt_space_size: */ (void)read_ref(d); (void)read_ref(d); e_boot_code = read_ref(d); spatic.size = (size_t) read_ref(d); alloc_space(&spatic, spatic.size); e_boot_code += (ref_t) spatic.start; { long load_count; ref_t *mptr, next; load_count = spatic.size; mptr = spatic.start; if (input_is_binary) { fread((void *)spatic.start, sizeof(ref_t), load_count, d); reoffset((ref_t) spatic.start, spatic.start, load_count); } else while (load_count != 0) { next = read_ref(d); if (next & 2) next += (ref_t) spatic.start; *mptr++ = next; --load_count; } /* Load the weak pointer table. */ wp_index = read_ref(d); if (wp_index + 1 > wp_table_size) { fprintf(stderr, "Error (loading world): number of weak pointers in world" " exceeds internal table size.\n"); exit(EXIT_FAILURE); } load_count = wp_index; mptr = &wp_table[1]; if (input_is_binary) { fread((void *)&wp_table[1], sizeof(ref_t), (long)wp_index, d); reoffset((ref_t) spatic.start, &wp_table[1], wp_index); } else while (load_count != 0) { next = read_ref(d); if (next & 2) next += (ref_t) spatic.start; *mptr++ = next; --load_count; } } /* The weak pointer hash table is rebuilt when e_nil is set. */ fclose(d); } oaklisp-1.3.3.orig/src/emulator/cmdline.c0000664000175000000620000001662511036404255017271 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #define _REENTRANT #include #include #include #include #include #include "config.h" #include "data.h" #include "cmdline.h" #include "xmalloc.h" #include "stacks.h" enum { FLAG_ARG = 0, HELP_ARG, WORLD_ARG, DUMP_ARG, DUMP_BASE_ARG, PREDUMP_GC_ARG, HEAP_ARG, VALSIZ_ARG, CXTSIZ_ARG, MAX_SEG_ARG, VERBOSE_GC_ARG, }; void usage(char *prog) { fprintf(stdout, "The Oaklisp bytecode emulator.\n" "\n" "Usage: %s emulator-options -- oaklisp-options\n" "\n" " emulator options:\n" "\n" "\t--help print this message and terminate\n" "\n" "\t--world file file is world to load\n" "\t--dump file dump world to file upon exit\n" "\t--d file synonym for --dump\n" "\t--dump-base b 10 or 16=ascii, 2=binary; default=2\n" "\t--predump-gc b 0=no, 1=yes; default=1\n" "\n" "\t--size-heap n n is in kilo-refs, default %d\n" "\t--size-val-stk n value stack buffer, n is in refs\n" "\t--size-cxt-stk n context stack buffer, n is in refs\n" "\t--size-seg-max n maximum flushed segment len, n is in refs\n" "\n" "\t--trace-gc v 0=quiet, 3=very detailed; default=0\n" "\t--verbose-gc v synonym for --trace-gc\n" "\t--trace-traps\n" #ifndef FAST "\t--trace-segs trace stack segment writes/reads\n" "\t--trace-valcon print entire value stack at each instr\n" "\t--trace-cxtcon print entire context stack at each instr\n" "\t--trace-stks print the size of the stacks at each instr\n" "\t--trace-instructions trace each bytecode executed\n" "\t--trace-methods trace each method lookup\n" #ifdef OP_TYPE_METH_CACHE "\t--trace-mcache trace method cache\n" #endif #endif "\t--trace-files trace filesystem operations\n" "\n" " oaklisp options:\n" "\n" "\tTry \"man oaklisp\" or run \"%s -- --help\"\n" "\n", /* "\type (MAP CAR COMMANDLINE-OPTIONS) to a running oaklisp\n" */ prog, DEFAULT_NEWSPACE, prog); } /* These store the command line arguments not eaten by the emulator, which the running world can access. */ int program_argc; char **program_argv; int program_arg_char(int arg_index, int char_index) { char *a; if (arg_index >= program_argc) return -1; a = program_argv[arg_index]; if (char_index > strlen(a)) return -1; return a[char_index]; } void parse_cmd_line(int argc, char **argv) { int retval, option_index = 0; #ifdef THREADS /* This is so value_stack.size and value_stack.filltarget can be set. Something is wrong because these should apply to all threads even the first, so they shouldn't need to know anything about threads ... ? */ int my_index; int *my_index_p; my_index_p = pthread_getspecific (index_key); my_index = *my_index_p; #endif { char *w = getenv("OAKWORLD"); if (w) world_file_name = w; } /* parse command line arguments */ while (1) { static struct option long_options[] = { {"help", no_argument, 0, HELP_ARG}, {"world", required_argument, 0, WORLD_ARG}, {"dump", required_argument, 0, DUMP_ARG}, {"d", required_argument, 0, DUMP_ARG}, {"dump-base", required_argument, 0, DUMP_BASE_ARG}, {"predump-gc", required_argument, 0, PREDUMP_GC_ARG}, {"size-heap", required_argument, 0, HEAP_ARG}, {"size-val-stk", required_argument, 0, VALSIZ_ARG}, {"size-cxt-stk", required_argument, 0, CXTSIZ_ARG}, {"size-seg-max", required_argument, 0, MAX_SEG_ARG}, {"trace-gc", required_argument, 0, VERBOSE_GC_ARG}, {"trace-traps", no_argument, &trace_traps, true}, #ifndef FAST {"trace-segs", no_argument, &trace_segs, true}, {"trace-valcon", no_argument, &trace_valcon, true}, {"trace-cxtcon", no_argument, &trace_cxtcon, true}, {"trace-stks", no_argument, &trace_stks, true}, {"trace-instructions", no_argument, &trace_insts, true}, {"trace-methods", no_argument, &trace_meth, true}, #ifdef OP_TYPE_METH_CACHE {"trace-mcache", no_argument, &trace_mcache, true}, #endif #endif {"trace-files", no_argument, &trace_files, true}, {0, 0, 0, 0}}; retval = getopt_long_only(argc, argv, "", long_options, &option_index); if (retval == EOF) break; switch (retval) { default: fprintf(stderr, "error: command line syntax\n"); case '?': /* getopt_long_only() already printed an error message. */ usage(argv[0]); exit(EXIT_FAILURE); break; case FLAG_ARG: /* variable set by getopt() itself */ break; case WORLD_ARG: world_file_name = optarg; break; case DUMP_ARG: dump_file_name = optarg; dump_flag = true; break; case DUMP_BASE_ARG: dump_flag = true; dump_base = atoi(optarg); if (dump_base != 2 && dump_base != 10 && dump_base != 16) { fprintf(stderr, "Error (command line parser): invalid" " dump base %s.\n", optarg); exit(EXIT_FAILURE); } break; case PREDUMP_GC_ARG: gc_before_dump = atoi(optarg); break; case HEAP_ARG: original_newspace_size = 1024 * atol(optarg); break; case VALSIZ_ARG: value_stack.size = atoi(optarg); value_stack.filltarget = value_stack.size/2; break; case CXTSIZ_ARG: context_stack.size = atoi(optarg); context_stack.filltarget = context_stack.size/2; break; case MAX_SEG_ARG: max_segment_size = atoi(optarg); break; case VERBOSE_GC_ARG: trace_gc = atoi(optarg); break; case HELP_ARG: usage(argv[0]); exit(EXIT_SUCCESS); break; } } /* Check to make sure that the stacks will work. We need the following guarantee: we must be able to pull in segments to allow a (LOAD-STK 255) instruction. This means that the stack buffer must be at least 255. Furthermore, we must be able to satisfy this by unflushing segments. The unflushing routine only pulls in integral segments, so we must be able to unflush a maximal segment if there are only 254 elements in the buffer. Therefore we must have: value_stack.size >= 254 + max_segment_size */ if (value_stack.size < 254 + max_segment_size) { value_stack.size = 254 + max_segment_size; fprintf(stderr, "warning: using value stack of size %d.\n", value_stack.size); } /* put remainder of command line in variables accessed by Oaklisp-level argline instructions */ program_argc = argc - optind; program_argv = argv + optind; return; } oaklisp-1.3.3.orig/src/emulator/stacks-loop.h0000664000175000000620000001307207725515165020130 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA #ifndef STACKS_LOOP_INCLUDED #define STACKS_LOOP_INCLUDED #include "stacks.h" #define LOCALIZE_VAL() \ { local_value_sp = value_stack.sp; \ } #define UNLOCALIZE_VAL() \ { value_stack.sp = local_value_sp; \ } #define LOCALIZE_CXT() \ { local_context_sp = context_stack.sp; \ } #define UNLOCALIZE_CXT() \ { context_stack.sp = local_context_sp; \ } #define LOCALIZE_REGS() \ { local_epc = e_pc; \ } #define UNLOCALIZE_REGS() \ { e_pc = local_epc; \ } #define LOCALIZE_STKS() \ { LOCALIZE_VAL(); \ LOCALIZE_CXT(); \ } #define UNLOCALIZE_STKS() \ { UNLOCALIZE_VAL(); \ UNLOCALIZE_CXT(); \ } #define LOCALIZE_ALL() \ { LOCALIZE_STKS(); \ LOCALIZE_REGS(); \ } #define UNLOCALIZE_ALL() \ { UNLOCALIZE_STKS(); \ UNLOCALIZE_REGS(); \ } #define VALUE_FLUSH(amount_to_leave) \ { UNLOCALIZE_ALL(); \ stack_flush(&value_stack, (amount_to_leave)); \ LOCALIZE_ALL(); \ } #define CONTEXT_FLUSH(amount_to_leave) \ { UNLOCALIZE_ALL(); \ stack_flush(&context_stack, (amount_to_leave)); \ LOCALIZE_ALL(); \ } #define VALUE_UNFLUSH(n) \ { UNLOCALIZE_VAL(); \ stack_unflush(&value_stack, (n)); \ LOCALIZE_VAL(); \ } #define CONTEXT_UNFLUSH(n) \ { UNLOCALIZE_CXT(); \ stack_unflush(&context_stack, (n)); \ LOCALIZE_CXT(); \ } #define DUMP_VALUE_STACK() \ { UNLOCALIZE_VAL(); \ dump_stack(&value_stack); \ } #define DUMP_CONTEXT_STACK() \ { UNLOCALIZE_CXT(); \ dump_stack(&context_stack); \ } #define VALUE_STACK_HEIGHT() \ (local_value_sp - value_stack_bp + 1 \ + value_stack.pushed_count) #define CONTEXT_STACK_HEIGHT() \ (local_context_sp - context_stack_bp + 1 \ + context_stack.pushed_count) /* The top of stack is always visible. Therefore PEEKVAL() can be used as an lvalue. */ #define PEEKVAL() (*local_value_sp) /* When you are sure that the buffer has enough elements in it, use this for looking deeper into the stack */ #define PEEKVAL_UP(x) (*(local_value_sp-(x))) /* Use these when you are sure that overflows and underflows cannot occur. */ #define PUSHVAL_NOCHECK(r) { *++local_value_sp = (r); } #define POPVAL_NOCHECK() (*local_value_sp--) #define PUSHVAL(r) \ { \ if (local_value_sp+1 < value_stack_end) \ { *++local_value_sp = (r); } \ else { \ GC_MEMORY(r); \ VALUE_FLUSH(value_stack.filltarget); \ GC_RECALL(*++local_value_sp); \ } \ } #define PUSHVAL_IMM(r) \ { \ CHECKVAL_PUSH(1); \ PUSHVAL_NOCHECK((r)); \ } #define POPVAL(v) \ { \ CHECKVAL_POP(1); \ (v) = *local_value_sp--; \ } /* The following routines check that n elements can be pushed without overflow */ #define CHECKVAL_PUSH(n) \ { if (&local_value_sp[(n)] >= value_stack_end) \ VALUE_FLUSH(value_stack.filltarget); \ } #define CHECKCXT_PUSH(n) \ { if (&local_context_sp[(n)] >= \ context_stack_end) \ CONTEXT_FLUSH(context_stack.filltarget); \ } /* The following check that n elements can be popped without underflow. */ #define CHECKVAL_POP(n) \ { if (&local_value_sp[-(n)] < value_stack_bp) \ VALUE_UNFLUSH((n)); \ } #define CHECKCXT_POP(n) \ { if (&local_context_sp[-(n)] < context_stack_bp) \ CONTEXT_UNFLUSH((n)); \ } /* This routine avoids having a bogus reference in the segments */ #define BASH_SEGMENT_TYPE() \ { value_stack.segment = e_nil; \ context_stack.segment = e_nil; \ } /* This pops some elements off the value stack. It is inefficient because it copies elements into the buffer and then pops them off. A better thing should be written. */ #define POPVALS(n) \ { CHECKVAL_POP((n)); \ local_value_sp -= (n); \ } #define POPCXTS(n) \ { CHECKCXT_POP((n)); \ local_context_sp -= (n); \ } #define PUSH_CONTEXT(off_set) \ { \ CHECKCXT_PUSH(CONTEXT_FRAME_SIZE); \ local_context_sp[1] = INT_TO_REF((unsigned long)local_epc - \ (unsigned long)e_code_segment +((off_set)<<1)); \ local_context_sp[2] = e_current_method; \ local_context_sp[3] = PTR_TO_LOC(e_bp); \ local_context_sp += 3; \ } #define POP_CONTEXT() \ { \ CHECKCXT_POP(CONTEXT_FRAME_SIZE); \ e_bp = LOC_TO_PTR(local_context_sp[0]); \ e_current_method = local_context_sp[-1]; \ e_env = REF_TO_PTR(e_current_method); \ e_code_segment = SLOT(e_env,METHOD_CODE_OFF); \ e_env = REF_TO_PTR(SLOT(e_env,METHOD_ENV_OFF)); \ local_epc = (u_int16_t *) \ ((unsigned long)e_code_segment \ +REF_TO_INT(local_context_sp[-2])); \ local_context_sp -= 3; \ } #define BASH_VAL_HEIGHT(h) \ { int to_pop = VALUE_STACK_HEIGHT()-(h); \ POPVALS(to_pop); \ } #define BASH_CXT_HEIGHT(h) \ { int to_pop = CONTEXT_STACK_HEIGHT()-(h); \ POPCXTS(to_pop); \ } #define MAKE_BACK_VAL_PTR(v,dist) \ { CHECKVAL_POP((dist)); \ (v) = local_value_sp - (dist); \ } #endif oaklisp-1.3.3.orig/src/emulator/cmdline.h0000664000175000000620000000234011036404255017263 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #ifndef _CMDLINE_H_INCLUDED #define _CMDLINE_H_INCLUDED extern void parse_cmd_line(int argc, char **argv); extern int program_arg_char(int arg_index, int char_index); #endif oaklisp-1.3.3.orig/src/emulator/signal.h0000664000175000000620000000235311036404255017131 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #ifndef _SIGNAL_H_INCLUDED #define _SIGNAL_H_INCLUDED void enable_signal_polling(void); void disable_signal_polling(void); void clear_signal(void); extern int signal_poll_flag; #endif oaklisp-1.3.3.orig/src/emulator/threads.h0000664000175000000620000000212611036617577017321 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA #ifndef _THREADS_H_INCLUDED #define _THREADS_H_INCLUDED #include #include "config.h" #ifdef THREADS extern int next_index; extern pthread_key_t index_key; extern pthread_mutex_t index_lock; extern pthread_mutex_t alloc_lock; extern pthread_mutex_t test_and_set_locative_lock; #endif #ifdef THREADS #define THREADY(x) x #else #define THREADY(x) #endif #endif /*_THREADS_H_INCLUDED*/ oaklisp-1.3.3.orig/src/emulator/gc.c0000664000175000000620000004733311036404255016247 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #define _REENTRANT #include #include #include #include "data.h" #include "weak.h" #include "xmalloc.h" #include "stacks.h" #include "gc.h" #ifdef USE_VADVISE #include #endif #define FORTHREADS THREADY( for (my_index=0; my_index> 2; fprintf(fd, "[%ld;tag:%d;%c]", i, refin & TAG_MASK, suffix); } else fprintf(fd, "[%ld;tag:%d]", (long)(refin >> 2), refin & TAG_MASK); } #define GC_NULL(r) ((r)==pre_gc_nil || (r)==e_nil) /* This variant of get_length has to follow forwarding pointers so that it will work in the middle of a gc, when an object's type might already have been transported. */ static unsigned long gc_get_length(ref_t x) { if (TAG_IS(x, PTR_TAG)) { ref_t typ = REF_SLOT(x, 0); ref_t vlen_p = REF_SLOT(typ, TYPE_VAR_LEN_P_OFF); ref_t len; /* Is vlen_p forwarded? */ if (TAG_IS(vlen_p, LOC_TAG)) vlen_p = *LOC_TO_PTR(vlen_p); /* Is this object variable length? */ if (GC_NULL(vlen_p)) { /* Not variable length. */ len = REF_SLOT(typ, TYPE_LEN_OFF); /* Is length forwarded? */ if (TAG_IS(len, LOC_TAG)) len = *LOC_TO_PTR(len); return REF_TO_INT(len); } else return REF_TO_INT(REF_SLOT(x, 1)); } else { fprintf(stderr, "; WARNING!!! gc_get_length("); printref(stderr, x); fprintf(stderr, ") called; only a tag of %d is allowed.\n", PTR_TAG); return 0; } } static ref_t gc_touch0(ref_t r) { ref_t *p = ANY_TO_PTR(r); if (OLD_PTR(p)) if (r & 1) { ref_t type_slot = *p; if (TAG_IS(type_slot, LOC_TAG)) /* Already been transported. */ /* Tag magic transforms this: return(PTR_TO_REF(LOC_TO_PTR(type_slot))); to this: */ return type_slot | 1L; else { /* Transport it */ long i; long len = gc_get_length(r); ref_t *new_place = free_point; ref_t *p0 = p; ref_t *q0 = new_place; transport_count += 1; /* fprintf(stderr, "About to transport "); printref(r); fprintf(stderr, " len = %ld.\n", len); */ free_point += len; #ifndef FAST if (free_point >= new_space.end) { fprintf(stderr, "\n; New space exhausted while transporting "); printref(stderr, r); fprintf(stderr, ".\n; This indicates a bug in the garbage collector.\n"); exit(EXIT_FAILURE); } #endif for (i = 0; i < len; i++, p0++, q0++) { *q0 = *p0; *p0 = PTR_TO_LOC(q0); } return (PTR_TO_REF(new_place)); } } else { /* Follow the chain of locatives to oldspace until we find a real object or a circularity. */ ref_t r0 = r, r1 = *p, *pp; /* int chain_len = 1; */ while (TAG_IS(r1, LOC_TAG) && (pp = LOC_TO_PTR(r1), OLD_PTR(pp))) { if (r0 == r1) { /* fprintf(stderr, "Circular locative chain.\n"); */ goto forwarded_loc; } r0 = *LOC_TO_PTR(r0); r1 = *pp; /* chain_len += 1; */ if (r0 == r1) { /* fprintf(stderr, "Circular locative chain.\n"); */ goto forwarded_loc; } if (!TAG_IS(r1, LOC_TAG) || (pp = LOC_TO_PTR(r1), !OLD_PTR(pp))) break; r1 = *pp; /* chain_len += 1; */ } /* We're on an object, so touch it. */ /* fprintf(stderr, "Locative chain followed to "); printref(r1); fprintf(stderr, " requiring %d dereferences.\n", chain_len); */ GC_TOUCH(r1); /* (void)gc_touch(r1); */ /* Now see if we're looking at a forwarding pointer. */ forwarded_loc: return (r); } else return (r); } static ref_t loc_touch0(ref_t r, bool warn_if_unmoved) { ref_t *p = LOC_TO_PTR(r); if (OLD_PTR(p)) { /* A locative into old space. See if it's been transported yet. */ ref_t r1 = *p; if (TAG_IS(r1, LOC_TAG) && NEW_PTR(LOC_TO_PTR(r1))) /* Already been transported. */ return (r1); else { /* Better transport this lonely cell. */ ref_t *new_place = free_point++; /* make a new cell. */ ref_t new_r = PTR_TO_LOC(new_place); #ifndef FAST if (free_point >= new_space.end) { fprintf(stderr, "\n; New space exhausted while transporting the cell "); printref(stderr, r); fprintf(stderr, ".\n; This indicates a bug in the garbage collector.\n"); exit(EXIT_FAILURE); } #endif *p = new_r; /* Record the transportation. */ /* Put the right value in the new cell. */ *new_place = TAG_IS(r1, PTR_TAG) && (p = REF_TO_PTR(r1), OLD_PTR(p)) ? *p | 1 : r1; /* ? PTR_TO_REF(REF_TO_PTR(*p)) : r1; */ loc_transport_count += 1; if (warn_if_unmoved) { fprintf(stderr, "\nWarning: the locative "); printref(stderr, r); fprintf(stderr, " has just had its raw cell moved.\n"); } return (new_r); } } else return (r); /* Not a locative into old space. */ } static void scavenge(void) { ref_t *scavenge_p; for (scavenge_p = new_space.start; scavenge_p < free_point; scavenge_p += 1) GC_TOUCH(*scavenge_p); } static void loc_scavenge(void) { ref_t *scavenge_p; for (scavenge_p = new_space.start; scavenge_p < free_point; scavenge_p += 1) LOC_TOUCH(*scavenge_p); } #ifndef FAST /* This set of routines are for consistency checks */ #define GGC_CHECK(r) GC_CHECK(r,"r") /* True if r seems like a messed up reference. */ static bool gc_check_(ref_t r) { return (r & PTR_MASK) && !NEW_PTR(ANY_TO_PTR(r)) && (full_gc || !SPATIC_PTR(ANY_TO_PTR(r))); } static void GC_CHECK(ref_t x, char *st) { if (gc_check_(x)) { fprintf(stderr, "%s = ", st); printref(stderr, x); if (OLD_PTR(ANY_TO_PTR(x))) { fprintf(stderr, ", cell contains "); printref(stderr, *ANY_TO_PTR(x)); } fprintf(stderr, "\n"); } } static void GC_CHECK1(ref_t x, char *st, long i) { if (gc_check_((x))) { fprintf(stderr, (st), (i)); printref(stderr, x); if (OLD_PTR(ANY_TO_PTR(x))) { fprintf(stderr, ", cell contains "); printref(stderr, *ANY_TO_PTR(x)); } fprintf(stderr, "\n"); } } #endif static u_int16_t * pc_touch(u_int16_t * o_pc) { ref_t *pcell = (ref_t *) ((unsigned long)o_pc & ~TAG_MASKL); /* It is possible that the gc was called while a vm was executing the last instruction in a code block (hopefully a branch or funcall) in a multithreaded enviornment. So let's back up the pc one before gc'ing it. However, this means the gc generally should not be called until the loop has read at least one instruction in the code block. */ /* pcell--; Changed my mind. Moved POLL_GC_SIGNALS to top of loop. */ LOC_TOUCH_PTR(pcell); /* pcell++; */ return (u_int16_t *) ((u_int32_t) pcell | ((u_int32_t) o_pc & TAG_MASK)); } static void set_external_full_gc(bool full) { full_gc = full; } void gc(bool pre_dump, bool full_gc, char *reason, size_t amount) /* * pre_dump About to dump world? (discards stacks) * full_gc Reclaim garbage from spatic space too? * reason The reason for this GC, human readable. * amount The amount of space that is needed. */ { long old_taken; long old_spatic_taken; ref_t *p; #ifdef THREADS bool ready=false; int my_index; int i; int *my_index_p; my_index_p = pthread_getspecific (index_key); my_index = *my_index_p; gc_ready[my_index] = 1; set_gc_flag (true); #endif #ifdef THREADS /*Problem here is next_index could change if someone creates a thread while someone else is gc'ing*/ while (ready == false) { ready = true; for (i = 0; i < next_index; i++) { if (gc_ready[i] == 0) { ready = false; break; } } } #endif /* The full_gc flag is also a global to avoid ugly parameter passing. */ set_external_full_gc(full_gc); gc_top: if (trace_gc == 1) fprintf(stderr, "\n;GC"); if (trace_gc > 1) fprintf(stderr, "\n; %sGC due to %s.\n", full_gc ? "Full " : "", reason); if (trace_gc > 2 && !pre_dump) { FORTHREADS { fprintf (stderr, "value "); dump_stack (value_stack_address); fprintf (stderr, "context "); dump_stack (context_stack_address); } } if (trace_gc > 1) fprintf(stderr, "; Flipping..."); old_taken = free_point - new_space.start; old_spatic_taken = spatic.size; old_space = new_space; if (trace_gc > 2) fprintf(stderr, "old taken: %ld", old_taken); if (full_gc) new_space.size += spatic.size; else new_space.size = e_next_newspace_size; alloc_space(&new_space, new_space.size); free_point = new_space.start; transport_count = 0; if (trace_gc > 1) fprintf(stderr, " rooting..."); { /* Hit the registers: */ pre_gc_nil = e_nil; GC_TOUCH(e_nil); GC_TOUCH(e_boot_code); if (!pre_dump) { GC_TOUCH(e_t); GC_TOUCH(e_fixnum_type); GC_TOUCH(e_loc_type); GC_TOUCH(e_cons_type); GC_TOUCH_PTR(e_subtype_table, 2); /* e_nargs is a fixnum. Nor is it global... */ GC_TOUCH (e_env_type); GC_TOUCH_PTR (e_argless_tag_trap_table, 2); GC_TOUCH_PTR (e_arged_tag_trap_table, 2); GC_TOUCH (e_object_type); GC_TOUCH (e_segment_type); FORTHREADS { /* e_bp is a locative, but a pointer to the object should exist, so we need only touch it in the locative pass. */ GC_TOUCH_PTR(e_env, 0); GC_TOUCH (e_code_segment); GC_TOUCH (e_current_method); GC_TOUCH (e_process); } GC_TOUCH (e_uninitialized); GC_TOUCH (e_method_type); GC_TOUCH (e_operation_type); FORTHREADS { for (p = gc_examine_buffer; p < gc_examine_ptr; p++) GC_TOUCH(*p); } /* Scan the stacks. */ FORTHREADS { for (p = value_stack.bp; p <= value_stack.sp; p++) GC_TOUCH(*p); for (p = context_stack.bp; p <= context_stack.sp; p++) GC_TOUCH(*p); /* Scan the stack segments. */ GC_TOUCH(value_stack.segment); GC_TOUCH(context_stack.segment); } /* Scan static space. */ if (!full_gc) for (p = spatic.start; p < spatic.end; p++) GC_TOUCH(*p); } /* Scavenge. */ if (trace_gc > 1) fprintf(stderr, " scavenging..."); scavenge(); if (trace_gc > 1) fprintf(stderr, " %ld object%s transported.\n", transport_count, transport_count != 1 ? "s" : ""); /* Clean up the locatives. */ if (trace_gc > 1) fprintf(stderr, "; Scanning locatives..."); loc_transport_count = 0; if (!pre_dump) { FORTHREADS { LOC_TOUCH_PTR (e_bp); e_pc = pc_touch (e_pc); LOC_TOUCH(e_uninitialized); for (p = gc_examine_buffer; p < gc_examine_ptr; p++) LOC_TOUCH(*p); for (p = value_stack.bp; p <= value_stack.sp; p++) LOC_TOUCH(*p); for (p = context_stack.bp; p <= context_stack.sp; p++) LOC_TOUCH(*p); } /* Scan spatic space. */ if (!full_gc) for (p = spatic.start; p < spatic.end; p++) LOC_TOUCH(*p); } if (trace_gc > 1) fprintf(stderr, " scavenging..."); loc_scavenge(); if (trace_gc > 1) fprintf(stderr, " %ld naked cell%s transported.\n", loc_transport_count, loc_transport_count != 1 ? "s" : ""); /* Discard weak pointers whose targets have not been transported. */ if (trace_gc > 1) fprintf(stderr, "; Scanning weak pointer table..."); { long count = post_gc_wp(); if (trace_gc > 1) fprintf(stderr, " %ld entr%s discarded.\n", count, count != 1 ? "ies" : "y"); } } #ifndef FAST { /* Check GC consistency. */ if (trace_gc > 1) fprintf(stderr, "; Checking consistency...\n"); GGC_CHECK(e_nil); GGC_CHECK(e_boot_code); if (!pre_dump) { GGC_CHECK (e_t); GGC_CHECK (e_fixnum_type); GGC_CHECK (e_loc_type); GGC_CHECK (e_cons_type); GC_CHECK (PTR_TO_REF (e_subtype_table - 2), "e_subtype_table"); FORTHREADS { GC_CHECK (PTR_TO_LOC (e_bp), "PTR_TO_LOC(E_BP)"); GC_CHECK (PTR_TO_REF (e_env), "e_env"); } /* e_nargs is a fixnum. Nor is it global... */ GGC_CHECK (e_env_type); GC_CHECK (PTR_TO_REF (e_argless_tag_trap_table - 2), "e_argless_tag_trap_table"); GC_CHECK (PTR_TO_REF (e_arged_tag_trap_table - 2), "e_arged_tag_trap_table"); GGC_CHECK (e_object_type); GGC_CHECK (e_segment_type); FORTHREADS { GGC_CHECK (e_code_segment); GGC_CHECK (e_current_method); GGC_CHECK (e_process); } GGC_CHECK (e_uninitialized); GGC_CHECK (e_method_type); GGC_CHECK (e_operation_type); /* Scan the stacks. */ FORTHREADS { for (p = value_stack.bp; p <= value_stack.sp; p++) GC_CHECK1(*p, "value_stack.bp[%d] = ", (long)(p - value_stack.bp)); for (p = context_stack.bp; p <= context_stack.sp; p++) GC_CHECK1(*p, "context_stack.bp[%d] = ", (long)(p - context_stack.bp)); GGC_CHECK(value_stack.segment); GGC_CHECK(context_stack.segment); /* Make sure the program counter is okay. */ GC_CHECK ((ref_t) ((ref_t) e_pc | LOC_TAG), "e_pc"); } } /* Scan the heap. */ if (!full_gc) for (p = spatic.start; p < spatic.end; p++) GC_CHECK1(*p, "static_space[%ld] = ", (long)(p - spatic.start)); for (p = new_space.start; p < free_point; p++) GC_CHECK1(*p, "new_space[%ld] = ", (long)(p - new_space.start)); } #endif /* not defined(FAST) */ /* Hopefully there are no more references into old space. */ if (!pre_dump) free_space(&old_space); if (!pre_dump && full_gc) free_space(&spatic); #ifdef USE_VADVISE #ifdef VA_FLUSH /* Tell the virtual memory system that recent statistics are useless. */ vadvise(VA_FLUSH); #endif #endif if (trace_gc > 2 && !pre_dump) { FORTHREADS { #ifdef THREADS fprintf (stderr, "Thread %d\n", my_index); #endif fprintf (stderr, "value_stack "); dump_stack (value_stack_address); fprintf (stderr, "context_stack "); dump_stack (context_stack_address); } } { long new_taken = free_point - new_space.start; long old_total = old_taken + (full_gc ? old_spatic_taken : 0); long reclaimed = old_total - new_taken; if (trace_gc == 1) { fprintf(stderr, ":%ld%%", (100 * reclaimed) / old_total); } if (trace_gc > 1) { fprintf(stderr, "; GC complete. %ld ", old_total); if (full_gc) fprintf(stderr, "(%ld+%ld) ", old_spatic_taken, old_taken); fprintf(stderr, "compacted to %ld; %ld (%ld%%) garbage.\n", new_taken, reclaimed, (100 * reclaimed) / old_total); } /* Make the next new space bigger if the current was too small. */ if (!full_gc && !pre_dump && (RECLAIM_FACTOR * new_taken + amount > new_space.size)) { e_next_newspace_size = RECLAIM_FACTOR * new_taken + amount; #ifdef MAX_NEW_SPACE_SIZE if (e_next_newspace_size > MAX_NEW_SPACE_SIZE) e_next_newspace_size = MAX_NEW_SPACE_SIZE; #endif switch (trace_gc) { case 0: break; case 1: fprintf(stderr, ",resize:%ld", (long)e_next_newspace_size); break; default: fprintf(stderr, "; Expanding next new space from %ld to %ld (%ld%%).\n", (long)new_space.size, (long)e_next_newspace_size, (long)(100 * (e_next_newspace_size - new_space.size)) / new_space.size); break; } if ((size_t) (new_space.end - free_point) < amount) { #ifdef MAX_NEW_SPACE_SIZE if (((new_space.end - free_point) + amount) < e_next_newspace_size) { fprintf(stderr, "\nFatal GC error:" "Essential new space size exceeds maximum allowable.\n"); exit(EXIT_FAILURE); } #endif reason = "immediate new space expansion necessity"; goto gc_top; } } if (full_gc && !pre_dump) { /* move _new to spatic, and reallocate new. */ spatic = new_space; realloc_space(&spatic, free_point - new_space.start); if (trace_gc > 1 && e_next_newspace_size != original_newspace_size) fprintf(stderr, "; Setting new space size to %ld.\n", (long)original_newspace_size); new_space.size = e_next_newspace_size = original_newspace_size; if (e_next_newspace_size <= amount) { e_next_newspace_size = RECLAIM_FACTOR * amount; switch (trace_gc) { case 0: break; case 1: fprintf(stderr, ",resize:%ld", (long)e_next_newspace_size); break; default: fprintf(stderr, "; expanding next new space %ld to %ld (%d%%).\n", (long)new_space.size, (long)e_next_newspace_size, (int)((100 * (e_next_newspace_size - new_space.size)) / new_space.size)); break; } new_space.size = e_next_newspace_size; } alloc_space(&new_space, new_space.size); free_point = new_space.start; } if (trace_gc == 1) fprintf(stderr, "\n"); if (trace_gc) fflush(stdout); } #ifdef THREADS my_index_p = pthread_getspecific (index_key); my_index = *my_index_p; gc_ready[my_index] = 0; set_gc_flag (false); #endif } /* This routine takes a block of memory and scans through it, updating all pointers into the window starting at old_start to instead point into the corresponding location in new_start. Typically new_start will be the same as start */ void shift_targets(ref_t * start, size_t len, ref_t * old_start, size_t old_len, ref_t * new_start) { size_t i; for (i = 0; i < len; i++) { ref_t x = start[i]; if (PTR_MASK & x) /* is it a pointer? */ { ref_t *y = ANY_TO_PTR(x); size_t offset = y - old_start; if (y >= 0 && offset < old_len) /* into old window? */ start[i] = PTR_TO_TAGGED(new_start + offset, x); } } } oaklisp-1.3.3.orig/src/emulator/timers.h0000664000175000000620000000235411036404255017160 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #ifndef _TIMERS_H_INCLUDED #define _TIMERS_H_INCLUDED /* the functions return milliseconds */ extern unsigned long get_real_time(void); extern unsigned long get_user_time(void); #endif oaklisp-1.3.3.orig/src/emulator/stacks.c0000664000175000000620000001467411036404255017150 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #define _REENTRANT #include #include #include #include "config.h" #include "data.h" #include "xmalloc.h" #include "gc.h" #include "stacks.h" int max_segment_size = 256; ref_t stack_top(oakstack *stack_p) { return *stack_p->sp; } void stack_newtos(oakstack *stack_p, ref_t x) { *stack_p->sp = x; } ref_t stack_pop(oakstack *stack_p) { if (stack_p->sp <= stack_p->bp) { stack_unflush(stack_p, stack_p->filltarget); } return *stack_p->sp; } void stack_push(oakstack *stack_p, ref_t x) { if (stack_p->sp == stack_p->bp + stack_p->size) stack_flush(stack_p, stack_p->filltarget); *++stack_p->sp = x; } void stack_flush(oakstack * stack_p, int amount_to_leave) { /* flushes out the value stack buffer, leaving amount_to_leave */ segment_t *s; int i; int count = stack_p->sp - stack_p->bp + 1; int amount_to_flush = count - amount_to_leave; int amount_unflushed = amount_to_flush; ref_t *src = stack_p->bp; ref_t *end = stack_p->sp - amount_to_leave; /* flush everything between src & end, them move portion of buffer after end down to beginning of buffer. */ #ifndef FAST if (trace_segs) printf("seg:flush-"); #endif while (src <= end) { /* Flush a single segment. */ long size = amount_unflushed; if (size > max_segment_size) size = max_segment_size; /* allocate a new segment */ { ref_t *p; ALLOCATE(p, (size + SEGMENT_HEADER_LENGTH), "space crunch allocating stack segment"); s = (segment_t *)p; } /* fill in header of new segment */ s->type_field = e_segment_type; s->length_field = INT_TO_REF(size + SEGMENT_HEADER_LENGTH); /* link segment onto head of flushed segment list */ s->previous_segment = stack_p->segment; stack_p->segment = PTR_TO_REF(s); for (i = 0; i < size; i++) s->data[i] = *src++; amount_unflushed -= size; #ifndef FAST if (trace_segs) printf("%ld-", size); #endif } for (i = 0; i < amount_to_leave; i++) stack_p->bp[i] = *src++; stack_p->sp = &stack_p->bp[amount_to_leave - 1]; stack_p->pushed_count += amount_to_flush; #ifndef FAST if (trace_segs) printf(".\n"); #endif } /* This routine grabs some segments that have been flushed from the buffer and puts them back in. Because the segments might be small, it may have to put more than one segment back in. It grabs enough so that the buffer has at least n+1 values in it, so that at least n values could be popped off without underflow. */ void stack_unflush(oakstack * stack_p, int n) { long i, number_to_pull = 0; long count = stack_p->sp - stack_p->bp + 1; long new_count = count; segment_t *s = (segment_t *) REF_TO_PTR(stack_p->segment); ref_t *dest; #ifndef FAST if (trace_segs) printf("seg:unflush-"); #endif /* First, figure out how many segments to pull. */ for (; new_count <= n; s = (segment_t *) REF_TO_PTR(s->previous_segment)) { int this_one = REF_TO_INT(s->length_field) - SEGMENT_HEADER_LENGTH; #ifndef FAST if (trace_segs) printf("%d-", this_one); #endif new_count += this_one; number_to_pull += 1; } #ifndef FAST if (trace_segs) printf("(%ld)-", number_to_pull); #endif /* Copy the data in the buffer up to its new home. */ dest = &stack_p->bp[new_count - 1]; for (i = count - 1; i >= 0; i--) *dest-- = stack_p->bp[i]; /* Suck in the segments. */ for (s = (segment_t *) REF_TO_PTR(stack_p->segment); number_to_pull > 0; number_to_pull--) { /* Suck in this segment. */ for (i = REF_TO_INT(s->length_field) - SEGMENT_HEADER_LENGTH - 1 ; i >= 0; i--) *dest-- = s->data[i]; s = (segment_t *) REF_TO_PTR(s->previous_segment); #ifndef FAST if (trace_segs) printf("p"); #endif } stack_p->segment = PTR_TO_REF(s); stack_p->sp = &stack_p->bp[new_count - 1]; stack_p->pushed_count -= (int)(new_count - count); #ifndef FAST if (trace_segs) printf(".\n"); #endif } void dump_stack(oakstack * stack_p) { /* dump part of stack, which is not segmented */ ref_t *p; fprintf(stdout, "stack contents (height: %d): ", stack_p->sp - stack_p->bp + 1 + stack_p->pushed_count); for (p = stack_p->bp; p <= stack_p->sp; ++p) { printref(stdout, *p); putc(p == stack_p->sp ? '\n' : ' ', stdout); } fflush(stdout); } void init_stacks(void) { #ifdef THREADS int *my_index_p; int my_index; #endif ref_t *ptr; /* For debugging we allocate two ref_t more and initialise these with a special pattern to detect out-of-range writes with assert() */ /* Initialise value stack */ #ifdef THREADS my_index_p = pthread_getspecific (index_key); my_index = *my_index_p; #endif ptr = (ref_t *) xmalloc((value_stack.size + 2) * sizeof(ref_t)); *ptr = PATTERN; ptr[value_stack.size + 1] = PATTERN; value_stack.bp = ptr + 1; value_stack.sp = value_stack.bp; *value_stack.bp = INT_TO_REF(1234); /* This becomes e_nil when segment_type is loaded. */ value_stack.segment = e_nil; value_stack.pushed_count = 0; /* Initialise context stack */ ptr = (ref_t *) xmalloc((context_stack.size + 2) * sizeof(ref_t)); *ptr = PATTERN; ptr[context_stack.size + 1] = PATTERN; context_stack.bp = ptr + 1; context_stack.sp = context_stack.bp; *context_stack.bp = INT_TO_REF(1234); /* This becomes e_nil when segment_type is loaded. */ context_stack.segment = e_nil; context_stack.pushed_count = 0; } oaklisp-1.3.3.orig/src/emulator/gc.h0000664000175000000620000000341111036404255016241 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #ifndef _GC_H_INCLUDED #define _GC_H_INCLUDED #include "config.h" #include "data.h" extern bool full_gc; extern void printref(FILE * fd, ref_t refin); extern void gc(bool pre_dump, bool full_gc, char *reason, size_t amount); #define GC_MEMORY(v) \ {*gc_examine_ptr++ = (v);} /* assert(gc_examine_ptr < &gc_examine_buffer[GC_EXAMINE_BUFFER_SIZE]);\ } */ #define GC_RECALL(v) \ {(v) = *--gc_examine_ptr;} /* assert(gc_examine_ptr >= gc_examine_buffer);\ } */ #ifdef THREADS extern int gc_ready[]; extern bool gc_pending; extern pthread_mutex_t gc_lock; #endif extern void set_gc_flag (bool flag); extern int get_next_index(); extern void free_registers(); extern void wait_for_gc(); #endif oaklisp-1.3.3.orig/src/emulator/Makefile0000664000175000000620000000440011036404255017136 0ustar barakstaff# This file is part of Oaklisp. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html # or from the Free Software Foundation, 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA # Copyright (c) 1999 Barak A. Pearlmutter # Distributed under the GNU General Public License v2 or later # This value of prefix will usually be overridden prefix=/usr/local psrc=oaklisp.c osrc=cmdline.c data.c gc.c loop.c signal.c stacks.c timers.c weak.c worldio.c xmalloc.c instr.c threads.c hsrc=cmdline.h config.h data.h gc.h loop.h signal.h stacks.h stacks-loop.h timers.h weak.h worldio.h xmalloc.h instr.h threads.h progs=$(psrc:.c=) pobj=$(psrc:.c=.o) oobj=$(osrc:.c=.o) all: $(progs) CFLAGS=-O2 -g -Wall LOADLIBES=-lpthread OAK=oaklisp # bootstrapping problem: to compile the emulator we need a working # oaklisp to generate instr-data.c. instr-data.c: instruction-table.oak $(OAK) $(OAKFLAGS) -- \ --locale compiler-locale \ --load instruction-table \ --eval '(dump-instruction-table "$@")' \ --exit -indent $@ # Things you might want to modify and uncomment: # CPPFLAGS+=-DMAX_NEW_SPACE_SIZE=16000000 # CPPFLAGS+=-DDEFAULT_WORLD=\"/usr/share/lib/oaklisp/oakworld.bin\" # CPPFLAGS+=-DFAST CPPFLAGS+=-DDEFAULT_WORLD=\"$(prefix)/lib/oaklisp/oakworld.bin\" $(progs): $(pobj) $(oobj) # automatically update #include dependencies dfiles = $(psrc:.c=.d) $(osrc:.c=.d) -include $(dfiles) override CPPFLAGS+=-MMD TAGS: $(psrc) $(osrc) $(hsrc) etags $^ > $@ d=$(DESTDIR)$(prefix)/bin .PHONY: install install: $(progs) mkdir --parents $d cp -a $(progs) $d/ cd $d; strip $(progs) .PHONY: clean clean: -rm -f $(progs) $(psrc:.c=.o) $(osrc:.c=.o) $(dfiles) TAGS .PHONY: indent indent: $(psrc) $(osrc) $(hsrc) indent --no-space-after-casts --no-space-after-function-call-names $^ oaklisp-1.3.3.orig/src/emulator/weak.h0000664000175000000620000000263311036404255016604 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #ifndef _WEAK_H_INCLUDED #define _WEAK_H_INCLUDED #include "data.h" void init_weakpointer_tables(void); void rebuild_wp_hashtable(void); ref_t ref_to_wp(ref_t r); extern unsigned long post_gc_wp(void); /* Weak pointer table and weak pointer hashtable */ extern const int wp_table_size, wp_hashtable_size; extern ref_t *wp_table; extern int wp_index; #endif oaklisp-1.3.3.orig/src/emulator/worldio.h0000664000175000000620000000227611036404255017337 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #ifndef _WORLDIO_H_INCLUDED #define _WORLDIO_H_INCLUDED extern void dump_world(bool justnew); extern void read_world(char *string); #endif oaklisp-1.3.3.orig/src/emulator/Makefile.nm0000664000175000000620000000264111036617552017562 0ustar barakstaff# MS Visual C 6.0 nmake makefile # by Blake McBride # This file is part of Oaklisp. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html # or from the Free Software Foundation, 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA CFLAGS = -nologo -DFAST -I../getopt -O2 -DDEFAULT_WORLD=\"oakworld.bin\" oaklisp.exe : \ cmdline.obj \ data.obj \ gc.obj \ getopt.obj \ getopt1.obj \ instr.obj \ loop.obj \ oaklisp.obj \ signal.obj \ stacks.obj \ timers.obj \ weak.obj \ worldio.obj \ xmalloc.obj cl -nologo -Fe$@ $** getopt.obj : ../getopt/getopt.c cl $(CFLAGS) -c $** getopt1.obj : ../getopt/getopt1.c cl $(CFLAGS) -c $** instr-data.c: instruction-table.oak oaklisp.exe oaklisp $(OAKFLAGS) -- \ -locale compiler-locale -load instruction-table \ -eval "(dump-instruction-table \"$@\")" \ -exit -indent $@ clean : -del *.obj realclean : clean -del oaklisp.exe oaklisp-1.3.3.orig/src/emulator/threads.c0000664000175000000620000001210011036617577017305 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA #define _REENTRANT #include #include #include #include #include "threads.h" #include "xmalloc.h" #include "stacks.h" #include "loop.h" #include "gc.h" #ifdef THREADS int next_index = 0; pthread_key_t index_key; pthread_mutex_t gc_lock = PTHREAD_MUTEX_INITIALIZER; pthread_mutex_t alloc_lock = PTHREAD_MUTEX_INITIALIZER; pthread_mutex_t index_lock = PTHREAD_MUTEX_INITIALIZER; pthread_mutex_t test_and_set_locative_lock = PTHREAD_MUTEX_INITIALIZER; bool gc_pending = false; int gc_ready[MAX_THREAD_COUNT]; register_set_t* register_array[MAX_THREAD_COUNT]; oakstack *value_stack_array[MAX_THREAD_COUNT]; oakstack *cntxt_stack_array[MAX_THREAD_COUNT]; #endif #ifdef THREADS static u_int16_t tail_recurse_instruction = (22 << 2); #endif typedef struct { ref_t start_operation; int parent_index; int my_index; } start_info_t; #ifdef THREADS static void *init_thread(void *info_p); #endif int create_thread(ref_t start_operation) { #ifdef THREADS pthread_t new_thread; int index; start_info_t *info_p = (start_info_t *)malloc(sizeof(start_info_t)); index = get_next_index(); if (index == -1) { fprintf (stderr, "Max thread count of %d has been exceeded. No thread created\n", MAX_THREAD_COUNT); return 0; } gc_ready[index] = 0; info_p->start_operation = start_operation; info_p->parent_index = *((int *)pthread_getspecific(index_key)); info_p->my_index = index; if (pthread_create(&new_thread, NULL, (void *)init_thread, (void *)info_p)) // Error creating --- need to add some clean up code here !!! return 0; else return 1; #else return 0; #endif } #ifdef THREADS static void *init_thread (void *info_p) { int my_index; int *my_index_p; start_info_t info; my_index_p = (int *)malloc(sizeof(int)); info = *((start_info_t *)info_p); free(info_p); /* Retrieve the next index in the thread arrays and lock it so another starting thread cannot get the same index */ *my_index_p = info.my_index; my_index = *my_index_p; pthread_setspecific(index_key, (void *)my_index_p); /* Increment also releases the gc lock on next_index so another starting thread can get the lock, or a thread that is gc'ing can get the lock */ /* Shouldn't get interrupted for gc until after stacks are created. This is below here in the vm not checking intterupts until after we get to the loop */ value_stack_array[my_index] = (oakstack*)malloc (sizeof (oakstack)); cntxt_stack_array[my_index] = (oakstack*)malloc(sizeof (oakstack)); value_stack_array[my_index]->size = value_stack_array[0]->size; value_stack_array[my_index]->filltarget = value_stack_array[0]->filltarget; cntxt_stack_array[my_index]->size = cntxt_stack_array[0]->size; cntxt_stack_array[my_index]->filltarget = cntxt_stack_array[0]->filltarget; init_stacks (); register_array[my_index] = (register_set_t*)malloc(sizeof (register_set_t)); memcpy(register_array[my_index], register_array[info.parent_index], sizeof(register_set_t)); gc_examine_ptr = gc_examine_buffer; /* At this point, it should be OK if the garbage collector gets run. */ e_pc = &tail_recurse_instruction; e_nargs = 0; /* Big virtual machine interpreter loop */ loop(info.start_operation); return 0; } #endif void set_gc_flag (bool flag) { #ifdef THREADS int *my_index_p; int my_index; my_index_p = pthread_getspecific (index_key); my_index = *(my_index_p); if (flag == true) { pthread_mutex_lock (&gc_lock); gc_pending = flag; } else { gc_pending = flag; pthread_mutex_unlock (&gc_lock); } #endif } /* Increment uses the gc lock since we must be sure that a new thread does not get started and begin processing while the gc is already running. The get_next_index additionally ensures that no two threads get the same index when starting */ int get_next_index () { int ret = -1; #ifdef THREADS pthread_mutex_lock (&index_lock); if (next_index >= MAX_THREAD_COUNT) { ret = -1; } else { ret = next_index; next_index++; } pthread_mutex_unlock (&index_lock); #endif return (ret); } void free_registers () { } void wait_for_gc() { #ifdef THREADS int *my_index_p; int my_index; my_index_p = pthread_getspecific (index_key); my_index = *(my_index_p); gc_ready[my_index] = 1; pthread_mutex_lock (&gc_lock); gc_ready[my_index] = 0; pthread_mutex_unlock (&gc_lock); #endif } oaklisp-1.3.3.orig/src/emulator/data.h0000664000175000000620000002406311036404255016567 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #ifndef _DATA_H_INCLUDED #define _DATA_H_INCLUDED #include #include #include #include #include "config.h" #include "threads.h" /* Version and greeting */ extern const char *version, *compilation_date, *compilation_time; #ifndef bool typedef int bool; #endif #ifndef false #define false 0 #define true 1 #endif /* reference type */ typedef u_int32_t ref_t; /* space type */ typedef struct { ref_t *start; ref_t *end; size_t size; /* in size reference_t */ #ifdef UNALIGNED_MALLOC size_t displacement; #endif } space_t; extern space_t new_space, old_space, spatic; extern ref_t *free_point; /* Size of first newspace, in K */ #define DEFAULT_NEWSPACE 128 /* The following is for stack debugging */ #define PATTERN 0x0a0b0c0d #define CONTEXT_FRAME_SIZE 3 /* not a tunable parameter */ /* Garbage collection */ #define GC_EXAMINE_BUFFER_SIZE 16 #ifdef THREADS extern ref_t gc_examine_buffer_array[MAX_THREAD_COUNT][GC_EXAMINE_BUFFER_SIZE]; extern ref_t *gc_examine_ptr_array[MAX_THREAD_COUNT]; #define gc_examine_buffer gc_examine_buffer_array[my_index] #define gc_examine_ptr gc_examine_ptr_array[my_index] #else extern ref_t gc_examine_buffer[GC_EXAMINE_BUFFER_SIZE]; extern ref_t *gc_examine_ptr; #endif /* Virtual Machine registers */ typedef struct { ref_t *e_bp; ref_t *e_env; ref_t e_current_method; ref_t e_code_segment; u_int16_t *e_pc; unsigned e_nargs; ref_t e_process; } register_set_t; #ifdef THREADS extern ref_t e_t, e_nil, e_fixnum_type, e_loc_type, e_cons_type, e_env_type, *e_subtype_table, e_object_type, e_segment_type, e_boot_code, *e_arged_tag_trap_table, *e_argless_tag_trap_table, e_uninitialized, e_method_type, e_operation_type; #else extern ref_t *e_bp, *e_env, e_t, e_nil, e_fixnum_type, e_loc_type, e_cons_type, e_env_type, *e_subtype_table, e_object_type, e_segment_type, e_boot_code, e_code_segment, *e_arged_tag_trap_table, *e_argless_tag_trap_table, e_current_method, e_uninitialized, e_method_type, e_operation_type, e_process; extern u_int16_t *e_pc; extern unsigned e_nargs; #endif #define e_false e_nil extern size_t e_next_newspace_size, original_newspace_size; extern char *world_file_name; extern char *dump_file_name; extern int dump_base; extern bool dump_flag; extern bool gc_before_dump; extern int trace_gc; extern bool trace_traps; #ifndef FAST extern bool trace_insts; extern bool trace_segs; extern bool trace_valcon; extern bool trace_cxtcon; extern bool trace_stks; extern bool trace_meth; #ifdef OP_TYPE_METH_CACHE extern bool trace_mcache; #endif #endif extern bool trace_files; /* miscellanous */ #ifndef ISATTY #define ISATTY(stream) (isatty(fileno(stream))) #endif #define READ_MODE "r" #define WRITE_MODE "w" #define APPEND_MODE "a" #define READ_BINARY_MODE "rb" #define WRITE_BINARY_MODE "wb" /* Tag Scheme */ #define SIGN_16BIT_ARG(x) ((int16_t)(x)) #define TAGSIZE 2 #define TAG_MASK 3 #define TAG_MASKL 3l #define SUBTAG_MASK 0xff #define SUBTAG_MASKL 0xffl #define INT_TAG 0 #define IMM_TAG 1 #define LOC_TAG 2 #define PTR_TAG 3 #define PTR_MASK 2 #define CHAR_SUBTAG IMM_TAG #define TAG_IS(X,TAG) (((X)&TAG_MASK)==(TAG)) #define SUBTAG_IS(X,SUBTAG) (((X)&SUBTAG_MASK)==(SUBTAG)) /* #define OR_TAG */ #define REF_TO_INT(r) ((int32_t)r>>TAGSIZE) #define REF_TO_PTR(r) ((ref_t*)((r)-PTR_TAG)) /* #define REF_TO_PTR(r) ((ref_t*)((r)&~3ul)) */ /* This maybe used in slot calculations, where tag corrections can be done by the address calculation unit */ #define REF_TO_PTR_ADDR(r) ((ref_t*)((r) - PTR_TAG)) #define LOC_TO_PTR(r) ((ref_t*)((r) - LOC_TAG)) #define ANY_TO_PTR(r) ((ref_t*)((r) & ~TAG_MASKL)) #ifndef OR_TAG #define PTR_TO_LOC(p) ((ref_t)((ref_t)(p) + LOC_TAG)) #define PTR_TO_REF(p) ((ref_t)((ref_t)(p) + PTR_TAG)) #else #define PTR_TO_LOC(p) ((ref_t)((ref_t)(p) | LOC_TAG)) #define PTR_TO_REF(p) ((ref_t)((ref_t)(p) | PTR_TAG)) #endif /* Put q's tag onto p */ #define PTR_TO_TAGGED(p,q) ((ref_t)((ref_t)(p) + ((q) & TAG_MASK))) #define REF_TO_CHAR(r) ((char)((r)>>8)) #ifndef OR_TAG #define CHAR_TO_REF(c) (((ref_t)(c)<<8) + CHAR_SUBTAG) #else #define CHAR_TO_REF(c) (((ref_t)(c)<<8) | IMM_TAG) #endif #ifndef OR_TAG #define INT_TO_REF(i) ((ref_t)(((int32_t)(i)<> (__WORDSIZE-(TAGSIZE+1)); \ if ((highcrap != 0x0) && (highcrap != 0x7)) {code;} } */ /* The following is for 32-bit ref_t only */ #define OVERFLOWN_INT(i,code) \ { u_int32_t highcrap = (i) & 0xe0000000; \ if ((highcrap) && (highcrap != 0xe0000000)) {code;}} /* * Offsets for wired types. Offset includes type and * optional length fields when present. */ /* CONS-PAIR: */ #define CONS_PAIR_CAR_OFF 1 #define CONS_PAIR_CDR_OFF 2 /* TYPE: */ #define TYPE_LEN_OFF 1 #define TYPE_VAR_LEN_P_OFF 2 #define TYPE_SUPER_LIST_OFF 3 #define TYPE_IVAR_LIST_OFF 4 #define TYPE_IVAR_COUNT_OFF 5 #define TYPE_TYPE_BP_ALIST_OFF 6 #define TYPE_OP_METHOD_ALIST_OFF 7 #define TYPE_WIRED_P_OFF 8 /* METHOD: */ #define METHOD_CODE_OFF 1 #define METHOD_ENV_OFF 2 /* CODE-VECTOR: */ #define CODE_IVAR_MAP_OFF 2 #define CODE_CODE_START_OFF 3 /* OPERATION: */ #define OPERATION_LAMBDA_OFF 1 #define OPERATION_CACHE_TYPE_OFF 2 #define OPERATION_CACHE_METH_OFF 3 #define OPERATION_CACHE_TYPE_OFF_OFF 4 #define OPERATION_LENGTH 5 /* ESCAPE-OBJECT */ #define ESCAPE_OBJECT_VAL_OFF 1 #define ESCAPE_OBJECT_CXT_OFF 2 /* Continuation Objects */ #define CONTINUATION_VAL_SEGS 1 #define CONTINUATION_VAL_OFF 2 #define CONTINUATION_CXT_SEGS 3 #define CONTINUATION_CXT_OFF 4 #define SPACE_PTR(s,p) ((s).start<=(p) && (p)<(s).end) #define NEW_PTR(r) SPACE_PTR(new_space,(r)) #define SPATIC_PTR(r) SPACE_PTR(spatic,(r)) #define OLD_PTR(r) (SPACE_PTR(old_space,(r))||(full_gc&&SPACE_PTR(spatic,(r)))) /* Leaving r unsigned lets us checks for negative and too big in one shot: */ #define wp_to_ref(r) \ ( (u_int32_t)REF_TO_INT(r) >= (u_int32_t) wp_index ? \ e_nil : wp_table[1+(u_int32_t)REF_TO_INT((r))] ) /* This is used to allocate some storage. It calls gc when necessary. */ #define ALLOCATE(p, words, reason) \ ALLOCATE_PROT(p, words, reason,; ,; ) /* This is used to allocate some storage */ #define ALLOCATE_SS(p, words, reason) \ ALLOCATE_PROT(p, words, reason, \ { value_stack.sp = local_value_sp; \ context_stack.sp = local_context_sp; \ e_pc = local_epc; }, \ { local_epc = e_pc; \ local_context_sp = context_stack.sp; \ local_value_sp = value_stack.sp; }) /* This allocates some storage, assuming that v must be protected from gc. */ #define ALLOCATE1(p, words, reason, v) \ ALLOCATE_PROT(p, words, reason, \ { GC_MEMORY(v); \ value_stack.sp = local_value_sp; \ context_stack.sp = local_context_sp; \ e_pc = local_epc; }, \ { local_epc = e_pc; \ local_context_sp = context_stack.sp; \ local_value_sp = value_stack.sp; \ GC_RECALL(v); }) #define ALLOCATE_PROT(p, words, reason, before, after) \ { \ THREADY( \ while (pthread_mutex_trylock(&alloc_lock) != 0) { \ if (gc_pending) { \ before; wait_for_gc(); after; \ } \ } \ ) \ if (free_point + (words) >= new_space.end) \ { \ before; \ gc(false, false, (reason), (words)); \ after; \ } \ (p) = free_point; \ free_point += (words); \ THREADY( pthread_mutex_unlock (&alloc_lock); ) \ } /* These get slots out of Oaklisp objects, and may be used as lvalues. */ #define SLOT(p,s) (*((p)+(s))) #define REF_SLOT(r,s) SLOT(REF_TO_PTR(r),s) /* This is for the warmup code */ #define CODE_SEG_FIRST_INSTR(seg) \ ( (u_int16_t *)(REF_TO_PTR((seg)) + CODE_CODE_START_OFF) ) #ifdef THREADS #define reg_set register_array[my_index] #define value_stack (*value_stack_array[my_index]) #define context_stack (*cntxt_stack_array[my_index]) #define value_stack_address value_stack_array[my_index] #define context_stack_address cntxt_stack_array[my_index] #define e_code_segment ( (reg_set->e_code_segment) ) #define e_current_method ( (reg_set->e_current_method) ) #define e_pc ( (reg_set->e_pc) ) #define e_bp ( (reg_set->e_bp) ) #define e_env ( (reg_set->e_env) ) #define e_nargs ( (reg_set->e_nargs) ) #define e_process ( (reg_set->e_process) ) #else extern register_set_t *reg_set; #define value_stack_address &value_stack #define context_stack_address &context_stack #endif extern int create_thread(ref_t start_method); extern register_set_t* register_array[]; #endif oaklisp-1.3.3.orig/src/emulator/instr.h0000664000175000000620000000160207725515165017024 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA #ifndef INSTR_H_INCLUDED #ifndef FAST extern void print_instr(int /* op_field */, int /* arg_field */, u_int16_t * /* e_pc */); extern void print_pc(u_int16_t * /* e_pc */); #endif #endif oaklisp-1.3.3.orig/src/emulator/signal.c0000664000175000000620000000401611036404255017122 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ /* Handle signals by polling. In order to do this signal_poll_flag is set to > 0 when a signal comes in, and is checked and reset by the bytecode emulator at frequent intervals when it is safe to field an interrupt. BUG: This can delay interrupt handling when waiting for input. */ #define _REENTRANT #include #include #include #include #include "config.h" #include "signal.h" int signal_poll_flag = 0; static void intr_proc(int sig) { signal_poll_flag++; } void enable_signal_polling(void) { signal_poll_flag = 0; if (signal(SIGINT, intr_proc) == SIG_ERR) fprintf(stderr, "Cannot enable signal polling.\n"); } #if 0 /* the following is not used and commented out */ void disable_signal_polling(void) { signal_poll_flag = 0; if (signal(SIGINT, SIG_DFL) == SIG_ERR) fprintf(stderr, "Cannot disable signal polling.\n"); } void clear_signal(void) { signal_poll_flag = 0; } #endif /* commented out */ oaklisp-1.3.3.orig/src/emulator/stacks.h0000664000175000000620000000434611036404255017150 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #ifndef _STACKS_H_INCLUDED #define _STACKS_H_INCLUDED #include "config.h" #include "gc.h" #include "data.h" extern int max_segment_size; /* flushed stack segment. Allocated and gc'ed in the oaklisp heap. */ typedef struct { /* Do not rearange this structure or you'll be sorry! */ ref_t type_field; ref_t length_field; ref_t previous_segment; ref_t data[1]; } segment_t; #define SEGMENT_HEADER_LENGTH (sizeof(segment_t)/sizeof(ref_t)-1) /* stack type */ typedef struct { int size; /* size of stack buffer */ int filltarget; /* how high to fill buffer ideally */ ref_t *bp; /* pointer to this stack's "buffer" */ ref_t *sp; /* pointer to top element in stack */ ref_t segment; /* head of linked list of flushed segments */ int pushed_count; /* number of ref's in flushed segment list */ } oakstack; #ifdef THREADS extern oakstack *value_stack_array[]; extern oakstack *cntxt_stack_array[]; #else extern oakstack value_stack; extern oakstack context_stack; #endif extern void init_stacks(void); extern void stack_flush(oakstack * stack_p, int amount_to_leave); extern void stack_unflush(oakstack * stack_p, int n); extern void dump_stack(oakstack * stack_p); #endif oaklisp-1.3.3.orig/src/emulator/oaklisp.c0000664000175000000620000000564711036404255017322 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #define _REENTRANT #include #include #include #include #include #include "config.h" #include "data.h" #include "cmdline.h" #include "weak.h" #include "stacks.h" #include "worldio.h" #include "loop.h" #include "xmalloc.h" int main(int argc, char **argv) { #ifdef THREADS int my_index; int *my_index_p; pthread_key_create (&index_key, (void*)free_registers); #endif #ifdef THREADS my_index_p = (int *)malloc (sizeof (int)); *my_index_p = get_next_index(); pthread_setspecific (index_key, (void*)my_index_p); my_index_p = pthread_getspecific(index_key); my_index = *my_index_p; gc_ready[my_index] = 0; /* inc_next_index();*/ value_stack_array[my_index] = (oakstack*)malloc (sizeof (oakstack)); cntxt_stack_array[my_index] = (oakstack*)malloc(sizeof (oakstack)); value_stack.size = 1024; value_stack.filltarget = 1024/2; context_stack.size = 512; context_stack.filltarget = 512/2; gc_examine_ptr = gc_examine_buffer; #endif parse_cmd_line(argc, argv); init_weakpointer_tables(); init_stacks(); read_world(world_file_name); new_space.size = e_next_newspace_size = original_newspace_size; alloc_space(&new_space, new_space.size); free_point = new_space.start; #ifdef THREADS register_array[my_index] = (register_set_t*)malloc(sizeof(register_set_t)); #else reg_set = (register_set_t*)malloc(sizeof(register_set_t)); #endif /* Set the registers to the boot code */ e_current_method = e_boot_code; e_env = REF_TO_PTR(REF_SLOT(e_current_method, METHOD_ENV_OFF)); e_code_segment = REF_SLOT(e_current_method, METHOD_CODE_OFF); e_pc = CODE_SEG_FIRST_INSTR(e_code_segment); /* Put a reasonable thing in e_bp to avoid confusing GC */ e_bp = e_env; /* Tell the boot function the truth */ e_nargs = 0; /* Big virtual machine interpreter loop */ loop(INT_TO_REF(54321)); return 0; } oaklisp-1.3.3.orig/src/emulator/loop.c0000664000175000000620000013766511036617577016654 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************* * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * *********************************************************************/ #define _REENTRANT #include #include #include #ifndef FAST #undef NDEBUG #endif #include #include "config.h" #include "data.h" #include "stacks.h" #include "stacks-loop.h" #include "gc.h" #include "signal.h" #include "timers.h" #include "weak.h" #include "worldio.h" #include "loop.h" #include "cmdline.h" #include "xmalloc.h" #ifndef FAST #include "instr.h" #endif #define ENABLE_TIMER 1 bool trace_traps = false; /* trace tag traps */ bool trace_files = false; /* trace file opening */ #ifndef FAST bool trace_insts = false; /* trace instruction execution */ bool trace_valcon = false; /* trace stack contents */ bool trace_cxtcon = false; /* trace contents stack contents */ bool trace_stks = false; /* trace contents stack contents */ bool trace_segs = false; /* trace stack segment manipulation */ bool trace_meth = false; /* trace method lookup */ #ifdef OP_TYPE_METH_CACHE bool trace_mcache = false; /* trace method cache hits and misses */ #endif #endif bool gc_before_dump = true; /* do a GC before dumping the world */ #ifdef FAST #define maybe_put(x,s) #else static inline void maybe_put(bool v, char *s) { if (v) { printf(s); fflush(stdout); } } #endif #define NEW_STORAGE e_uninitialized void maybe_dump_world(int dumpstackp) { #ifdef THREADS int *my_index_p; int my_index; my_index_p = pthread_getspecific (index_key); my_index = *(my_index_p); #endif if (dumpstackp > 2) { /* 0,1,2 are normal exits. */ /* will be changed */ dump_stack(&value_stack); dump_stack(&context_stack); } if (dump_flag) { if (gc_before_dump && dumpstackp == 0) { gc(true, true, "impending world dump", 0); dump_world(true); } else dump_world(false); } } static inline ref_t get_type(ref_t x) { #ifndef USE_SWITCH_FOR_GET_TYPE if (x & 0x1) { if (x & 0x2) return REF_SLOT(x, 0); else return *(e_subtype_table + ((x & SUBTAG_MASK) / 4)); } else { if (x & 0x2) return e_loc_type; else return e_fixnum_type; } #else switch (x & TAG_MASK) { case INT_TAG: return e_fixnum_type; case IMM_TAG: return e_subtype_table[(x & SUBTAG_MASK) >> 2]; case LOC_TAG: return e_loc_type; case PTR_TAG: return REF_SLOT(x, 0); } #endif } static inline ref_t * pcar(ref_t x) { return &REF_SLOT(x, CONS_PAIR_CAR_OFF); } static inline ref_t * pcdr(ref_t x) { return &REF_SLOT(x, CONS_PAIR_CDR_OFF); } static inline ref_t car(ref_t x) { return *pcar(x); } static inline ref_t cdr(ref_t x) { return *pcdr(x); } static inline ref_t assq(ref_t elt, ref_t lis, ref_t notfound) { while (lis != e_nil) { ref_t this = car(lis); if (car(this) == elt) return this; lis = cdr(lis); } return notfound; } static inline ref_t assqcdr(ref_t elt, ref_t lis, ref_t notfound) { while (lis != e_nil) { ref_t this = car(lis); if (car(this) == elt) return cdr(this); lis = cdr(lis); } return notfound; } static inline int lookup_bp_offset(ref_t y_type, ref_t meth_type) { return assqcdr(meth_type, REF_SLOT(y_type, TYPE_TYPE_BP_ALIST_OFF), INT_TO_REF(0)); } static inline void find_method_type_pair(ref_t op, ref_t obj_type, ref_t *method_ptr, ref_t *type_ptr) { ref_t alist; ref_t car_cache; ref_t *locl = NULL; #ifdef OP_METH_ALIST_MTF ref_t thelist; ref_t *loclist; #endif /* stack of lists of types that remain to be searched */ ref_t later_lists[100]; ref_t *llp = &later_lists[-1]; while (1) /* forever */ { /* First look for it in the local method alist of obj_type: */ #ifdef OP_METH_ALIST_MTF alist = thelist = *(loclist = &REF_SLOT(obj_type, TYPE_OP_METHOD_ALIST_OFF)); #else alist = REF_SLOT(obj_type, TYPE_OP_METHOD_ALIST_OFF); #endif while (alist != e_nil) { if (car((car_cache = car(alist))) == op) { maybe_put(trace_meth, "x\n"); #ifdef OP_METH_ALIST_MTF if (locl != NULL) { *locl = cdr(alist); *loclist = alist; *pcdr(alist) = thelist; } #endif *method_ptr = cdr(car_cache); *type_ptr = obj_type; return; } alist = *(locl = pcdr(alist)); maybe_put(trace_meth, "-"); } /* Not found in local alist, so stack the entire supertype list and then fetch the top guy available on the stack. */ *++llp = REF_SLOT(obj_type, TYPE_SUPER_LIST_OFF); while (*llp == e_nil) { if (llp == later_lists) return; llp--; } locl = NULL; obj_type = car(*llp); *llp = cdr(*llp); } } void loop(ref_t initial_tos) { u_int16_t instr; u_int8_t op_field; u_int8_t arg_field; /* trap_nargs is used by instructions when they trap, to tell the trap code about a property of the instruction. (It might be better to instead the trap code look in a table.) */ unsigned trap_nargs; #ifdef THREADS int* my_index_p = pthread_getspecific (index_key); int my_index = *(my_index_p); #endif ref_t x = INT_TO_REF(0); /* x, y initialized for -Wall message */ ref_t y = INT_TO_REF(0); #if ENABLE_TIMER unsigned timer_counter = 0; unsigned timer_increment = 0; #endif /* These are "local" versions of some globals, to make sure the C compiler can keep these in registers or on the stack instead of reloading from main memory. */ u_int16_t *local_epc; ref_t *local_value_sp; ref_t *value_stack_bp = value_stack.bp; ref_t *value_stack_end = &value_stack.bp[value_stack.size]; ref_t *local_context_sp; ref_t *context_stack_bp = context_stack.bp; ref_t *context_stack_end = &context_stack.bp[context_stack.size]; LOCALIZE_ALL(); /* This fixes a bug in which the initial CHECK-NARGS in the boot code tries to pop the operation and fails. */ PUSHVAL_IMM(INT_TO_REF(4321)); PUSHVAL(initial_tos); /* These TRAPx(n) macros jump to the trap code, notifying it that x arguments have been popped off the stack and need to be put back on (these are in the variables x, ...) and that the trap operation should be called with the top n guys on the stack as arguments. */ #define TRAP0(N) {trap_nargs=((N)); goto arg0_tt;} #define TRAP1(N) {trap_nargs=((N)); goto arg1_tt;} #define TRAP0_IF(C,N) {if ((C)) TRAP0((N));} #define TRAP1_IF(C,N) {if ((C)) TRAP1((N));} #define CHECKTAG0(X,TAG,N) TRAP0_IF(!TAG_IS((X),(TAG)),(N)) #define CHECKTAG1(X,TAG,N) TRAP1_IF(!TAG_IS((X),(TAG)),(N)) #define CHECKCHAR0(X,N) \ TRAP0_IF(!SUBTAG_IS((X),CHAR_SUBTAG),(N)) #define CHECKCHAR1(X,N) \ TRAP1_IF(!SUBTAG_IS((X),CHAR_SUBTAG),(N)) #define CHECKTAGS1(X0,T0,X1,T1,N) \ TRAP1_IF( !TAG_IS((X0),(T0)) || !TAG_IS((X1),(T1)), (N)) #define CHECKTAGS_INT_1(X0,X1,N) \ TRAP1_IF( (((X0)|(X1)) & TAG_MASK) != 0, (N)) #define POLL_USER_SIGNALS() if ((signal_poll_flag) \ THREADY( && (my_index == 0))) \ {goto intr_trap;} #if ENABLE_TIMER #define TIMEOUT 1000 #define POLL_TIMER_SIGNALS() if (timer_counter > TIMEOUT) {goto intr_trap;} #else /* not ENABLE_TIMER */ #define POLL_TIMER_SIGNALS() #endif #ifdef THREADS #define POLL_GC_SIGNALS() if (gc_pending) { \ value_stack.sp = local_value_sp; \ context_stack.sp = local_context_sp; \ e_pc = local_epc; \ wait_for_gc(); \ local_epc = e_pc; \ local_context_sp = context_stack.sp; \ local_value_sp = value_stack.sp; \ } #else #define POLL_GC_SIGNALS() #endif #define POLL_SIGNALS() POLL_USER_SIGNALS() ; \ POLL_TIMER_SIGNALS() ; /* This is the big instruction fetch/execute loop. */ enable_signal_polling(); #define GOTO_TOP goto top_of_loop; top_of_loop: while (1) /* forever */ { #ifndef FAST if (trace_valcon) DUMP_VALUE_STACK(); if (trace_cxtcon) DUMP_CONTEXT_STACK(); if (trace_stks) { printf("heights val: %d = %d + %d, cxt: %d = %d + %d\n", VALUE_STACK_HEIGHT(), local_value_sp - value_stack_bp + 1, value_stack.pushed_count, CONTEXT_STACK_HEIGHT(), local_context_sp - context_stack_bp + 1, context_stack.pushed_count); } { int val_buffer_count = local_value_sp - value_stack_bp + 1; int cxt_buffer_count = local_context_sp - context_stack_bp + 1; if (val_buffer_count < 1 || val_buffer_count > value_stack.size) { fprintf(stderr, "vm error: val_buffer_count = %d\n", val_buffer_count); exit(EXIT_FAILURE); } /* Should this be a zero ??? */ if (cxt_buffer_count < 0 || cxt_buffer_count > context_stack.size) { fprintf(stderr, "vm error: cxt_buffer_count = %d\n", cxt_buffer_count); exit(1); } } #endif POLL_GC_SIGNALS(); #if ENABLE_TIMER timer_counter += timer_increment; #endif instr = *local_epc++; op_field = (instr >> 2) & 0x3F; arg_field = instr >> 8; #define signed_arg_field ((int8_t)arg_field) #ifndef FAST if (trace_insts) print_instr(op_field, arg_field, local_epc - 1); #endif /* fprintf(stdout, "Asserting...\n"); assert(value_stack_bp[-1] == PATTERN); assert(value_stack_bp[value_stack.size] == PATTERN); assert(context_stack_bp[-1] == PATTERN); assert(context_stack_bp[context_stack.size] == PATTERN); */ if (op_field == 0) { switch (arg_field) { case 0: /* NOOP */ GOTO_TOP; case 1: /* PLUS */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); { long a = REF_TO_INT(x) + REF_TO_INT(y); OVERFLOWN_INT(a, TRAP1(2)); PEEKVAL() = INT_TO_REF(a); } GOTO_TOP; case 2: /* NEGATE */ x = PEEKVAL(); CHECKTAG0(x, INT_TAG, 1); /* The most negative fixnum's negation isn't a fixnum. */ if (x == MIN_REF) TRAP0(1); /* Tag trickery: */ PEEKVAL() = -((long)x); GOTO_TOP; case 3: /* EQ? */ POPVAL(x); y = PEEKVAL(); PEEKVAL() = BOOL_TO_REF(x == y); GOTO_TOP; case 4: /* NOT */ PEEKVAL() = BOOL_TO_REF(PEEKVAL() == e_false); GOTO_TOP; case 5: /* TIMES */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); #ifdef __GLIBC_HAVE_LONG_LONG { int64_t a = (int64_t)REF_TO_INT(x) * (int64_t)REF_TO_INT(y); int highcrap = a >> (__WORDSIZE - (TAGSIZE+1)); if (highcrap && highcrap+1) TRAP1(2); PEEKVAL() = INT_TO_REF(a); } #elif defined(DOUBLES_FOR_OVERFLOW) { double a = (double)REF_TO_INT(x) * (double)REF_TO_INT(y); if (a < (double)((long)MIN_REF / 4) || a > (double)((long)MAX_REF / 4)) TRAP1(2); PEEKVAL() = INT_TO_REF((long)a); } #else { long a = REF_TO_INT(x), b = REF_TO_INT(y); unsigned long al, ah, bl, bh, hh, hllh, ll; long answer; bool neg = false; /* MNF check */ if (a < 0) { a = -a; neg = true; } if (b < 0) { b = -b; neg = !neg; } al = a & 0x7FFF; bl = b & 0x7FFF; ah = (unsigned long)a >> 15; bh = (unsigned long)b >> 15; ll = al * bl; hllh = al * bh + ah * bl; hh = ah * bh; if (hh || hllh >> 15) TRAP1(2); answer = (hllh << 15) + ll; if (neg) answer = -answer; OVERFLOWN_INT(answer, TRAP1(2)); PEEKVAL() = INT_TO_REF(answer); } #endif GOTO_TOP; case 6: /* LOAD-IMM ; INLINE-REF */ /* align pc to next word boundary: */ if ((unsigned long)local_epc & 0x2) local_epc++; /*NOSTRICT */ x = *(ref_t *)local_epc; PUSHVAL(x); local_epc += sizeof(ref_t) / sizeof(*local_epc); GOTO_TOP; case 7: /* DIV */ /* Sign of product of args. */ /* Round towards 0. Obeys identity w/ REMAINDER. */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); /* Can't divide by 0, or the most negative fixnum by -1. */ if (y == INT_TO_REF(0) || (y == INT_TO_REF(-1) && x == MIN_REF)) TRAP1(2); /* Tag trickery: */ PEEKVAL() = INT_TO_REF((long)x / (long)y); GOTO_TOP; case 8: /* =0? */ x = PEEKVAL(); CHECKTAG0(x, INT_TAG, 1); PEEKVAL() = BOOL_TO_REF(x == INT_TO_REF(0)); GOTO_TOP; case 9: /* GET-TAG */ PEEKVAL() = INT_TO_REF(PEEKVAL() & TAG_MASK); GOTO_TOP; case 10: /* GET-DATA */ /* With the moving gc, this should *NEVER* be used. For ease of debugging with the multiple spaces, this makes it seem like spatic and _new spaces are contiguous, is compatible with print_ref, and also with CRUNCH. */ x = PEEKVAL(); if (x & PTR_MASK) { ref_t *p = (x & 1) ? REF_TO_PTR(x) : LOC_TO_PTR(x); PEEKVAL() = INT_TO_REF( SPATIC_PTR(p) ? p - spatic.start : NEW_PTR(p) ? (p - new_space.start) + spatic.size : ( /* This is one weird reference: */ printf("GET-DATA of "), printref(stdout, x), printf("\n"), -(long)p - 1) ); } else PEEKVAL() = (x & ~TAG_MASKL) | INT_TAG; GOTO_TOP; case 11: /* CRUNCH */ POPVAL(x); /* data */ y = PEEKVAL(); /* tag */ CHECKTAGS_INT_1(x, y, 2); { int tag = (REF_TO_INT(y) & TAG_MASK); ref_t z; if (tag & PTR_MASK) { long i = REF_TO_INT(x); /* Preclude creation of very odd references. */ TRAP1_IF(i < 0, 2); if (i < (long)spatic.size) z = PTR_TO_LOC(spatic.start + i); else if (i < (long)(spatic.size + new_space.size)) z = PTR_TO_LOC(new_space.start + (i - spatic.size)); else { TRAP1(2); } } else z = x; PEEKVAL() = z | tag; } GOTO_TOP; case 12: /* GETC */ /* Used in emergency cold load standard-input stream. */ PUSHVAL_IMM(CHAR_TO_REF(getc(stdin))); GOTO_TOP; case 13: /* PUTC */ /* Used in emergency cold load standard-output stream and for the warm boot message. */ x = PEEKVAL(); CHECKCHAR0(x, 1); putc(REF_TO_CHAR(x), stdout); fflush(stdout); #ifndef FAST if (trace_insts || trace_valcon || trace_cxtcon) printf("\n"); #endif GOTO_TOP; case 14: /* CONTENTS */ x = PEEKVAL(); CHECKTAG0(x, LOC_TAG, 1); PEEKVAL() = *LOC_TO_PTR(x); GOTO_TOP; case 15: /* SET-CONTENTS */ POPVAL(x); CHECKTAG1(x, LOC_TAG, 2); *LOC_TO_PTR(x) = PEEKVAL(); GOTO_TOP; case 16: /* LOAD-TYPE */ PEEKVAL() = get_type(PEEKVAL()); GOTO_TOP; case 17: /* CONS */ { ref_t *p; ALLOCATE_SS(p, 3, "space crunch in CONS instruction"); POPVAL(x); p[CONS_PAIR_CAR_OFF] = x; p[CONS_PAIR_CDR_OFF] = PEEKVAL(); p[0] = e_cons_type; PEEKVAL() = PTR_TO_REF(p); GOTO_TOP; } case 18: /* <0? */ x = PEEKVAL(); CHECKTAG0(x, INT_TAG, 1); /* Tag trickery: */ PEEKVAL() = BOOL_TO_REF((int32_t)x < 0); GOTO_TOP; case 19: /* MODULO */ /* Sign of divisor (thing being divided by). */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); if (y == INT_TO_REF(0)) TRAP1(2); { long a = REF_TO_INT(x) % REF_TO_INT(y); if ((a < 0 && (long)y > 0) || ((long)y < 0 && (long)x > 0 && a > 0)) a += REF_TO_INT(y); PEEKVAL() = INT_TO_REF(a); } GOTO_TOP; case 20: /* ASH */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); /* Tag trickery: */ { long b = REF_TO_INT(y); if (b < 0) { PEEKVAL() = ((long)x >> -b) & ~TAG_MASKL; GOTO_TOP; } else { PEEKVAL() = x << b; GOTO_TOP; } } case 21: /* ROT */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); /* Rotations cannot overflow, but are not meaningful with an infinite-precision integer language model. This instr is used for computing string hashes. */ { unsigned long a = (unsigned long)x; long b = REF_TO_INT(y); if (b < 0) { PEEKVAL() = (a >> -b | a << (__WORDSIZE - 2 + b)) & ~TAG_MASKL; GOTO_TOP; } else { PEEKVAL() = (a << b | a >> (__WORDSIZE - 2 - b)) & ~TAG_MASKL; GOTO_TOP; } } case 22: /* STORE-BP-I */ POPVAL(x); CHECKTAG1(x, INT_TAG, 2); *(e_bp + REF_TO_INT(x)) = PEEKVAL(); GOTO_TOP; case 23: /* LOAD-BP-I */ x = PEEKVAL(); CHECKTAG0(x, INT_TAG, 1); PEEKVAL() = *(e_bp + REF_TO_INT(x)); GOTO_TOP; case 24: /* RETURN */ POP_CONTEXT(); GOTO_TOP; case 25: /* ALLOCATE */ { ref_t *p; POPVAL(x); y = PEEKVAL(); CHECKTAG1(y, INT_TAG, 2); ALLOCATE1(p, REF_TO_INT(y), "space crunch in ALLOCATE instruction", x); *p = x; PEEKVAL() = PTR_TO_REF(p); while (++p < free_point) *p = NEW_STORAGE; GOTO_TOP; } case 26: /* ASSQ */ POPVAL(x); PEEKVAL() = assq(x, PEEKVAL(), e_false); GOTO_TOP; case 27: /* LOAD-LENGTH */ x = PEEKVAL(); PEEKVAL() = (TAG_IS(x, PTR_TAG) ? (REF_SLOT(REF_SLOT(x, 0), TYPE_VAR_LEN_P_OFF) == e_false ? REF_SLOT(REF_SLOT(x, 0), TYPE_LEN_OFF) : REF_SLOT(x, 1)) : INT_TO_REF(0)); GOTO_TOP; case 28: /* PEEK */ PEEKVAL() = INT_TO_REF(*(u_int16_t *) PEEKVAL()); GOTO_TOP; case 29: /* POKE */ POPVAL(x); *(u_int16_t *) x = (u_int16_t) REF_TO_INT(PEEKVAL()); GOTO_TOP; case 30: /* MAKE-CELL */ { ref_t *p; ALLOCATE_SS(p, 1, "space crunch in MAKE-CELL instruction"); *p = PEEKVAL(); PEEKVAL() = PTR_TO_LOC(p); GOTO_TOP; } case 31: /* SUBTRACT */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); { long a = REF_TO_INT(x) - REF_TO_INT(y); OVERFLOWN_INT(a, TRAP1(2)); PEEKVAL() = INT_TO_REF(a); GOTO_TOP; } case 32: /* = */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); /* Tag trickery: */ PEEKVAL() = BOOL_TO_REF(x == y); GOTO_TOP; case 33: /* < */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); /* Tag trickery: */ PEEKVAL() = BOOL_TO_REF((long)x < (long)y); GOTO_TOP; case 34: /* LOG-NOT */ x = PEEKVAL(); CHECKTAG0(x, INT_TAG, 1); /* Tag trickery: */ PEEKVAL() = ~x - (TAG_MASK - INT_TAG); GOTO_TOP; case 35: /* LONG-BRANCH distance (signed) */ POLL_SIGNALS(); local_epc += ASHR2(SIGN_16BIT_ARG(*local_epc)) + 1; GOTO_TOP; case 36: /* LONG-BRANCH-NIL distance (signed) */ POLL_SIGNALS(); POPVAL(x); if (x != e_nil) local_epc++; else local_epc += ASHR2(SIGN_16BIT_ARG(*local_epc)) + 1; GOTO_TOP; case 37: /* LONG-BRANCH-T distance (signed) */ POLL_SIGNALS(); POPVAL(x); if (x == e_nil) local_epc++; else local_epc += ASHR2(SIGN_16BIT_ARG(*local_epc)) + 1; GOTO_TOP; case 38: /* LOCATE-BP-I */ x = PEEKVAL(); CHECKTAG0(x, INT_TAG, 1); PEEKVAL() = PTR_TO_LOC(e_bp + REF_TO_INT(x)); GOTO_TOP; case 39: /* LOAD-IMM-CON ; INLINE-REF */ /* This is like a LOAD-IMM followed by a CONTENTS. */ /* align pc to next word boundary: */ /* Do it in ?two? instructions: */ /* local_epc = (unsigned short*)(((unsigned long)local_epc + 3)&~3ul); */ /* Do it in ?three? instructions including branch: */ if ((unsigned long)local_epc & 2) local_epc++; /* NOSTRICT */ x = *(ref_t *) local_epc; local_epc += 2; /* This checktag looks buggy, since it's hard to back over the instruction normally ... need to expand this out */ CHECKTAG1(x, LOC_TAG, 1); x = *LOC_TO_PTR(x); PUSHVAL(x); GOTO_TOP; /* Cons access instructions. */ #define CONSINSTR(a) \ { x = PEEKVAL(); \ CHECKTAG0(x, PTR_TAG, a); \ if (REF_SLOT(x,0) != e_cons_type) { TRAP0(a); } } case 40: /* CAR */ CONSINSTR(1); PEEKVAL() = car(x); GOTO_TOP; case 41: /* CDR */ CONSINSTR(1); PEEKVAL() = cdr(x); GOTO_TOP; case 42: /* SET-CAR */ CONSINSTR(2); POPVALS(1); *pcar(x) = PEEKVAL(); GOTO_TOP; case 43: /* SET-CDR */ CONSINSTR(2); POPVALS(1); *pcdr(x) = PEEKVAL(); GOTO_TOP; case 44: /* LOCATE-CAR */ CONSINSTR(1); PEEKVAL() = PTR_TO_LOC(pcar(x)); GOTO_TOP; case 45: /* LOCATE-CDR */ CONSINSTR(1); PEEKVAL() = PTR_TO_LOC(pcdr(x)); GOTO_TOP; /* Done with cons access instructions. */ case 46: /* PUSH-CXT-LONG rel */ PUSH_CONTEXT(ASHR2(SIGN_16BIT_ARG(*local_epc)) + 1); local_epc++; GOTO_TOP; case 47: /* Call a primitive routine. */ fprintf(stderr, "Not configured for CALL-PRIMITIVE.\n"); GOTO_TOP; case 48: /* THROW */ POPVAL(x); CHECKTAG1(x, PTR_TAG, 2); y = PEEKVAL(); BASH_VAL_HEIGHT(REF_TO_INT(REF_SLOT(x, ESCAPE_OBJECT_VAL_OFF))); BASH_CXT_HEIGHT(REF_TO_INT(REF_SLOT(x, ESCAPE_OBJECT_CXT_OFF))); PUSHVAL(y); POP_CONTEXT(); GOTO_TOP; case 49: /* GET-WP */ PEEKVAL() = ref_to_wp(PEEKVAL()); GOTO_TOP; case 50: /* WP-CONTENTS */ x = PEEKVAL(); CHECKTAG0(x, INT_TAG, 1); PEEKVAL() = wp_to_ref(x); GOTO_TOP; case 51: /* GC */ UNLOCALIZE_ALL(); gc(false, false, "explicit call", 0); LOCALIZE_ALL(); PUSHVAL(e_false); GOTO_TOP; case 52: /* BIG-ENDIAN? */ x = BOOL_TO_REF(__BYTE_ORDER == __BIG_ENDIAN); PUSHVAL(x); GOTO_TOP; case 53: /* VLEN-ALLOCATE */ POPVAL(x); y = PEEKVAL(); CHECKTAG1(y, INT_TAG, 2); { ref_t *p; ALLOCATE1(p, REF_TO_INT(y), "space crunch in VARLEN-ALLOCATE instruction", x); PEEKVAL() = PTR_TO_REF(p); p[0] = x; p[1] = y; p += 2; while (p < free_point) *p++ = NEW_STORAGE; } GOTO_TOP; case 54: /* INC-LOC */ /* Increment a locative by an amount. This is an instruction rather than (%crunch (+ (%pointer loc) index) %locative-tag) to avoid a window of gc vulnerability. All such windows must be fully closed before engines come up. */ POPVAL(x); y = PEEKVAL(); CHECKTAGS1(x, LOC_TAG, y, INT_TAG, 2); PEEKVAL() = PTR_TO_LOC(LOC_TO_PTR(x) + REF_TO_INT(y)); GOTO_TOP; case 55: /* FILL-CONTINUATION */ /* This instruction fills a continuation object with the appropriate values. */ CHECKVAL_POP(1); VALUE_FLUSH(2); CONTEXT_FLUSH(0); #ifndef FAST /* debugging check: */ if (local_value_sp != &value_stack_bp[1]) printf("Value stack flushing error.\n"); if (local_context_sp != &context_stack_bp[-1]) printf("Context stack flushing error.\n"); #endif x = PEEKVAL(); /* CHECKTAG0(x,PTR_TAG,1); */ REF_SLOT(x, CONTINUATION_VAL_SEGS) = value_stack.segment; REF_SLOT(x, CONTINUATION_VAL_OFF) = INT_TO_REF(value_stack.pushed_count); REF_SLOT(x, CONTINUATION_CXT_SEGS) = context_stack.segment; REF_SLOT(x, CONTINUATION_CXT_OFF) = INT_TO_REF(context_stack.pushed_count); /* Maybe it's a good idea to reload the buffer, but I'm not bothering and things seem to work. */ /* CHECKCXT_POP(0); */ GOTO_TOP; case 56: /* CONTINUE */ /* Continue a continuation. */ /* Grab the continuation. */ POPVAL(x); /* CHECKTAG1(x,PTR_TAG,1); */ y = PEEKVAL(); /* Pull the crap out of it. */ value_stack.segment = REF_SLOT(x, CONTINUATION_VAL_SEGS); value_stack.pushed_count = REF_TO_INT(REF_SLOT(x, CONTINUATION_VAL_OFF)); local_value_sp = &value_stack_bp[-1]; PUSHVAL_NOCHECK(y); context_stack.segment = REF_SLOT(x, CONTINUATION_CXT_SEGS); context_stack.pushed_count = REF_TO_INT(REF_SLOT(x, CONTINUATION_CXT_OFF)); local_context_sp = &context_stack_bp[-1]; POP_CONTEXT(); GOTO_TOP; case 57: /* REVERSE-CONS */ /* This is just like CONS except that it takes its args in the other order. Makes open coded LIST better. */ { ref_t *p; ALLOCATE_SS(p, 3, "space crunch in REVERSE-CONS instruction"); POPVAL(x); p[CONS_PAIR_CDR_OFF] = x; p[CONS_PAIR_CAR_OFF] = PEEKVAL(); p[0] = e_cons_type; PEEKVAL() = PTR_TO_REF(p); GOTO_TOP; } case 58: /* MOST-NEGATIVE-FIXNUM? */ PEEKVAL() = BOOL_TO_REF( PEEKVAL() == MIN_REF ); GOTO_TOP; case 59: /* FX-PLUS */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); /* Tag trickery: */ PEEKVAL() = x + y; GOTO_TOP; case 60: /* FX-TIMES */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); /* Tag trickery: */ PEEKVAL() = REF_TO_INT(x) * y; GOTO_TOP; case 61: /* GET-TIME */ /* Return CPU time */ PUSHVAL_IMM(INT_TO_REF(get_user_time())); GOTO_TOP; case 62: /* REMAINDER */ /* Sign of dividend (thing being divided.) */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); if (y == INT_TO_REF(0)) TRAP1(2); PEEKVAL() = INT_TO_REF(REF_TO_INT(x) % REF_TO_INT(y)); GOTO_TOP; case 63: /* QUOTIENTM */ /* Round towards -inf. Obeys identity w/ MODULO. */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); /* Can't divide by 0, or the most negative fixnum by -1. */ if (y == INT_TO_REF(0) || (y == INT_TO_REF(-1) && x == MIN_REF)) TRAP1(2); /* Tag trickery: */ /* I can't seem to get anything like this to work: */ PEEKVAL() = INT_TO_REF((((long)x < 0) ^ ((long)y < 0)) ? -(long)x / -(long)y : (long)x / (long)y); { long a = (long)x / (long)y; if (((long)x < 0 && (long)y > 0 && a * (long)y > (long)x) || ((long)y < 0 && (long)x > 0 && a * (long)y < (long)x)) a -= 1; PEEKVAL() = INT_TO_REF(a); } GOTO_TOP; case 64: /* FULL-GC */ UNLOCALIZE_ALL(); gc(false, true, "explicit call", 0); LOCALIZE_ALL(); PUSHVAL(e_false); GOTO_TOP; case 65: /* MAKE-LAMBDA */ { ref_t *p; ALLOCATE_SS(p, 8, "space crunch in MAKE-LAMBDA instruction"); p[0] = e_operation_type; p[OPERATION_LAMBDA_OFF] = PTR_TO_REF(p + OPERATION_LENGTH); p[OPERATION_CACHE_TYPE_OFF] = NEW_STORAGE; p[OPERATION_CACHE_METH_OFF] = NEW_STORAGE; p[OPERATION_CACHE_TYPE_OFF_OFF] = NEW_STORAGE; POPVAL(x); p[OPERATION_LENGTH + METHOD_CODE_OFF] = x; p[OPERATION_LENGTH + METHOD_ENV_OFF] = PEEKVAL(); p[OPERATION_LENGTH] = e_method_type; PEEKVAL() = PTR_TO_REF(p); GOTO_TOP; } case 66: /* GET-ARGLINE-CHAR */ /* takes two args on stack, index into argv and index into that argument. Return a character (perhaps nul), or #f if out of bounds */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); { int c = program_arg_char(REF_TO_INT(x), REF_TO_INT(y)); PEEKVAL() = (c == -1) ? e_false : CHAR_TO_REF(c); } GOTO_TOP; case 67: /* ENABLE-ALARMS */ timer_increment = 1; PUSHVAL(e_nil); GOTO_TOP; case 68: /* DISABLE-ALARMS */ timer_increment = 0; PUSHVAL(e_nil); GOTO_TOP; case 69: /* RESET-ALARM-COUNTER */ timer_counter = 0; PUSHVAL(e_nil); GOTO_TOP; case 70: /* HEAVYWEIGHT-THREAD */ #ifdef THREADS PEEKVAL() = BOOL_TO_REF( create_thread(PEEKVAL()) ); #else PEEKVAL() = e_nil; #endif GOTO_TOP; case 71: /* TEST-AND-SET-LOCATIVE */ POPVAL(x); CHECKTAG1(x, LOC_TAG, 2); POPVAL(y); if (*LOC_TO_PTR(x) != y) { // fail PEEKVAL() = e_false; GOTO_TOP; } #ifdef THREADS if (pthread_mutex_trylock(&test_and_set_locative_lock) != 0) { PEEKVAL() = e_false; /* Failed to acquire lock. */ GOTO_TOP; } /* Start Critical Section. */ if (*(volatile ref *)LOC_TO_PTR(x) != y) { // fail PEEKVAL() = e_false; } else { // succeed *LOC_TO_PTR(x) = PEEKVAL(); PEEKVAL() = e_t; } pthread_mutex_unlock(&test_and_set_locative_lock); /* End Critical Section. */ GOTO_TOP; #else *LOC_TO_PTR(x) = PEEKVAL(); PEEKVAL() = e_t; GOTO_TOP; #endif #ifndef FAST default: printf("\nError (vm interpreter): " "Illegal argless instruction %d.\n", arg_field); UNLOCALIZE_ALL(); maybe_dump_world(333); exit(EXIT_FAILURE); #endif } } else { /* parametric instructions */ switch (op_field) { #ifndef FAST case 0: /* PARAMETERLESS-INSTRUCTION xxxx */ fprintf(stderr, "Error (vm interpreter): Internal error " "file: %s line: %d\n", __FILE__, __LINE__); exit(EXIT_FAILURE); #endif case 1: /* HALT n */ { int halt_code = arg_field; UNLOCALIZE_ALL(); maybe_dump_world(halt_code); exit(halt_code); } case 2: /* LOG-OP log-spec */ POPVAL(x); y = PEEKVAL(); CHECKTAGS_INT_1(x, y, 2); /* Tag trickery: */ PEEKVAL() = ((instr & (1 << 8) ? x & y : 0) | (instr & (1 << 9) ? ~x & y : 0) | (instr & (1 << 10) ? x & ~y : 0) | (instr & (1 << 11) ? ~x & ~y : 0)) & ~TAG_MASKL; GOTO_TOP; case 3: /* BLT-STACK stuff,trash */ { unsigned int stuff = arg_field & 0xf; unsigned int trash_m1 = arg_field >> 4; CHECKVAL_POP(stuff + trash_m1); { ref_t *src = local_value_sp - stuff; ref_t *dest = src - (trash_m1 + 1); while (src < local_value_sp) *++dest = *++src; local_value_sp = dest; } } GOTO_TOP; case 4: /* BRANCH-NIL distance (signed) */ POLL_SIGNALS(); POPVAL(x); if (x == e_nil) local_epc += signed_arg_field; GOTO_TOP; case 5: /* BRANCH-T distance (signed) */ POLL_SIGNALS(); POPVAL(x); if (x != e_nil) local_epc += signed_arg_field; GOTO_TOP; case 6: /* BRANCH distance (signed) */ POLL_SIGNALS(); local_epc += signed_arg_field; GOTO_TOP; case 7: /* POP n */ POPVALS(arg_field); GOTO_TOP; case 8: /* SWAP n */ x = PEEKVAL(); { ref_t *other; MAKE_BACK_VAL_PTR(other, arg_field); PEEKVAL() = *other; *other = x; } GOTO_TOP; case 9: /* BLAST n */ CHECKVAL_POP(arg_field); { ref_t *other = local_value_sp - arg_field; *other = POPVAL_NOCHECK(); } GOTO_TOP; case 10: /* LOAD-IMM-FIX signed-arg */ /* Tag trickery and opcode knowledge changes this PUSHVAL_IMM(INT_TO_REF(signed_arg_field)); to this: */ PUSHVAL_IMM((ref_t) (((int16_t) instr) >> 6)); GOTO_TOP; case 11: /* STORE-STK n */ { ref_t *other; MAKE_BACK_VAL_PTR(other, arg_field); *other = PEEKVAL(); } GOTO_TOP; case 12: /* LOAD-BP n */ x = *(e_bp + arg_field); PUSHVAL(x); GOTO_TOP; case 13: /* STORE-BP n */ *(e_bp + arg_field) = PEEKVAL(); GOTO_TOP; case 14: /* LOAD-ENV n */ x = *(e_env + arg_field); PUSHVAL(x); GOTO_TOP; case 15: /* STORE-ENV n */ *(e_env + arg_field) = PEEKVAL(); GOTO_TOP; case 16: /* LOAD-STK n */ /* All attempts to start this with if (arg_field == 0) for speed have failed, so benchmark carefully before trying it. */ { ref_t *other; MAKE_BACK_VAL_PTR(other, arg_field); x = *other; } PUSHVAL(x); GOTO_TOP; case 17: /* MAKE-BP-LOC n */ PUSHVAL(PTR_TO_LOC(e_bp + arg_field)); GOTO_TOP; case 18: /* MAKE-ENV-LOC n */ PUSHVAL(PTR_TO_LOC(e_env + arg_field)); GOTO_TOP; case 19: /* STORE-REG reg */ x = PEEKVAL(); switch (arg_field) { case 0: e_t = x; GOTO_TOP; case 1: e_nil = x; wp_table[0] = e_nil; rebuild_wp_hashtable(); GOTO_TOP; case 2: e_fixnum_type = x; GOTO_TOP; case 3: e_loc_type = x; GOTO_TOP; case 4: e_cons_type = x; GOTO_TOP; case 5: CHECKTAG1(x, PTR_TAG, 1); e_subtype_table = REF_TO_PTR(x) + 2; GOTO_TOP; case 6: CHECKTAG1(x, LOC_TAG, 1); e_bp = LOC_TO_PTR(x); GOTO_TOP; case 7: CHECKTAG1(x, PTR_TAG, 1); e_env = REF_TO_PTR(x); GOTO_TOP; case 8: CHECKTAG1(x, INT_TAG, 1); e_nargs = REF_TO_INT(x); GOTO_TOP; case 9: e_env_type = x; GOTO_TOP; case 10: CHECKTAG1(x, PTR_TAG, 1); e_argless_tag_trap_table = REF_TO_PTR(x) + 2; GOTO_TOP; case 11: CHECKTAG1(x, PTR_TAG, 1); e_arged_tag_trap_table = REF_TO_PTR(x) + 2; GOTO_TOP; case 12: e_object_type = x; GOTO_TOP; case 13: e_boot_code = x; GOTO_TOP; case 14: CHECKTAG1(x, LOC_TAG, 1); free_point = LOC_TO_PTR(x); GOTO_TOP; case 15: CHECKTAG1(x, LOC_TAG, 1); new_space.end = LOC_TO_PTR(x); GOTO_TOP; case 16: e_segment_type = x; BASH_SEGMENT_TYPE(); GOTO_TOP; case 17: e_uninitialized = x; GOTO_TOP; case 18: CHECKTAG1(x, INT_TAG, 1); e_next_newspace_size = REF_TO_INT(x); #ifdef MAX_NEW_SPACE_SIZE if (e_next_newspace_size > MAX_NEW_SPACE_SIZE) e_next_newspace_size = MAX_NEW_SPACE_SIZE; #endif GOTO_TOP; case 19: e_method_type = x; GOTO_TOP; case 20: e_operation_type = x; GOTO_TOP; case 21: e_false = x; /* wp_table[0] = e_false; */ /* rebuild_wp_hashtable(); */ GOTO_TOP; case 22: e_process = x; GOTO_TOP; default: printf("STORE-REG %d, unknown .\n", arg_field); GOTO_TOP; } case 20: /* LOAD-REG reg */ switch (arg_field) { case 0: PUSHVAL(e_t); GOTO_TOP; case 1: PUSHVAL(e_nil); GOTO_TOP; case 2: PUSHVAL(e_fixnum_type); GOTO_TOP; case 3: PUSHVAL(e_loc_type); GOTO_TOP; case 4: PUSHVAL(e_cons_type); GOTO_TOP; case 5: PUSHVAL(PTR_TO_REF(e_subtype_table - 2)); GOTO_TOP; case 6: PUSHVAL(PTR_TO_LOC(e_bp)) GOTO_TOP; case 7: PUSHVAL(PTR_TO_REF(e_env)); GOTO_TOP; case 8: PUSHVAL(INT_TO_REF((long)e_nargs)); GOTO_TOP; case 9: PUSHVAL(e_env_type); GOTO_TOP; case 10: PUSHVAL(PTR_TO_REF(e_argless_tag_trap_table - 2)); GOTO_TOP; case 11: PUSHVAL(PTR_TO_REF(e_arged_tag_trap_table - 2)); GOTO_TOP; case 12: PUSHVAL(e_object_type); GOTO_TOP; case 13: PUSHVAL(e_boot_code); GOTO_TOP; case 14: PUSHVAL(PTR_TO_LOC(free_point)); GOTO_TOP; case 15: PUSHVAL(PTR_TO_LOC(new_space.end)); GOTO_TOP; case 16: PUSHVAL(e_segment_type); GOTO_TOP; case 17: PUSHVAL(e_uninitialized); GOTO_TOP; case 18: PUSHVAL(INT_TO_REF(e_next_newspace_size)); GOTO_TOP; case 19: PUSHVAL(e_method_type); GOTO_TOP; case 20: PUSHVAL(e_operation_type); GOTO_TOP; case 21: PUSHVAL(e_false); GOTO_TOP; case 22: PUSHVAL(e_process); GOTO_TOP; default: fprintf(stderr, "Error (vm interpreter): " "LOAD-REG %d, unknown .\n", arg_field); PUSHVAL(e_false); GOTO_TOP; } case 21: /* FUNCALL-CXT, FUNCALL-CXT-BR distance */ /* NOTE: (FUNCALL-CXT) == (FUNCALL-CXT-BR 0) */ POLL_SIGNALS(); PUSH_CONTEXT(signed_arg_field); /* Fall through to tail recursive case: */ goto funcall_tail; case 22: /* FUNCALL-TAIL */ /* This polling should not be moved below the trap label, since the interrupt code will fail on a fake instruction failure. */ POLL_SIGNALS(); /* This label allows us to branch back up from a trap. */ /***********/ funcall_tail: /***********/ x = PEEKVAL(); CHECKTAG0(x, PTR_TAG, e_nargs + 1); CHECKVAL_POP(1); y = PEEKVAL_UP(1); e_current_method = REF_SLOT(x, OPERATION_LAMBDA_OFF); if (e_current_method == e_false) { /* SEARCH */ ref_t y_type = (e_nargs == 0) ? e_object_type : get_type(y); #ifdef OP_TYPE_METH_CACHE /* Check for cache hit: */ if (y_type == REF_SLOT(x, OPERATION_CACHE_TYPE_OFF)) { maybe_put(trace_mcache, "H"); e_current_method = REF_SLOT(x, OPERATION_CACHE_METH_OFF); e_bp = REF_TO_PTR(y) + REF_TO_INT(REF_SLOT(x, OPERATION_CACHE_TYPE_OFF_OFF)); } else #endif { /* Search the type hierarchy. */ ref_t meth_type, offset = INT_TO_REF(0); find_method_type_pair(x, y_type, &e_current_method, &meth_type); if (e_current_method == e_nil) { if (trace_traps) { printf("No handler for operation "); printref(stdout, x); printf(" type "); printref(stdout, y_type); printf("\n"); } TRAP0(e_nargs + 1); } /* This could be dispensed with if meth_type has no ivars and isn't variable-length-mixin. */ offset = lookup_bp_offset(y_type, meth_type); e_bp = REF_TO_PTR(y) + REF_TO_INT(offset); #ifdef OP_TYPE_METH_CACHE maybe_put(trace_mcache, "M"); /* Cache the results of this search. */ REF_SLOT(x, OPERATION_CACHE_TYPE_OFF) = y_type; REF_SLOT(x, OPERATION_CACHE_METH_OFF) = e_current_method; REF_SLOT(x, OPERATION_CACHE_TYPE_OFF_OFF) = offset; #endif } } else if (!TAG_IS(e_current_method, PTR_TAG) || REF_SLOT(e_current_method, 0) != e_method_type) { /* TAG TRAP */ if (trace_traps) printf("Bogus or never defined operation.\n"); TRAP0(e_nargs + 1); } /* else it's a LAMBDA. */ x = e_current_method; e_env = REF_TO_PTR(REF_SLOT(x, METHOD_ENV_OFF)); local_epc = CODE_SEG_FIRST_INSTR(e_code_segment = REF_SLOT(x, METHOD_CODE_OFF)); GOTO_TOP; case 23: /* STORE-NARGS n */ e_nargs = arg_field; GOTO_TOP; case 24: /* CHECK-NARGS n */ if (e_nargs == arg_field) { POPVALS(1); } else { if (trace_traps) printf("\n%d args passed; %d expected.\n", e_nargs, arg_field); TRAP0(e_nargs + 1); } GOTO_TOP; case 25: /* CHECK-NARGS-GTE n */ if (e_nargs >= arg_field) { POPVALS(1); } else { if (trace_traps) printf("\n%d args passed; %d or more expected.\n", e_nargs, arg_field); TRAP0(e_nargs + 1); } GOTO_TOP; case 26: /* STORE-SLOT n */ POPVAL(x); CHECKTAG1(x, PTR_TAG, 2); REF_SLOT(x, arg_field) = PEEKVAL(); GOTO_TOP; case 27: /* LOAD-SLOT n */ CHECKTAG0(PEEKVAL(), PTR_TAG, 1); PEEKVAL() = REF_SLOT(PEEKVAL(), arg_field); GOTO_TOP; case 28: /* MAKE-CLOSED-ENVIRONMENT n */ /* This code might be in error if arg_field == 0, which the compiler should never generate. */ { ref_t *p; ref_t z; #ifndef FAST if (arg_field == 0) { fprintf(stderr, "MAKE-CLOSED-ENVIRONMENT 0.\n"); fflush(stderr); } #endif ALLOCATE_SS(p, (long)(arg_field + 2), "space crunch in MAKE-CLOSED-ENVIRONMENT"); z = PTR_TO_REF(p); CHECKVAL_POP(arg_field - 1); *p++ = e_env_type; *p++ = INT_TO_REF(arg_field + 2); while (arg_field--) *p++ = POPVAL_NOCHECK(); PUSHVAL_NOCHECK(z); } GOTO_TOP; case 29: /* PUSH-CXT rel */ PUSH_CONTEXT(signed_arg_field); GOTO_TOP; case 30: /* LOCATE-SLOT n */ PEEKVAL() = PTR_TO_LOC(REF_TO_PTR(PEEKVAL()) + arg_field); GOTO_TOP; case 31: /* STREAM-PRIMITIVE n */ switch (arg_field) { case 0: /* get standard input stream. */ PUSHVAL((ref_t) stdin); GOTO_TOP; case 1: /* get standard output stream. */ PUSHVAL((ref_t) stdout); GOTO_TOP; case 2: /* get standard error output stream. */ PUSHVAL((ref_t) stderr); GOTO_TOP; case 3: /* fopen, mode READ */ case 4: /* fopen, mode WRITE */ case 5: /* fopen, mode APPEND */ POPVAL(x); /* How about a CHECKTAG(x,LOC_TAG,) here, eh? */ { char *s = (char *)oak_c_string((ref_t *) LOC_TO_PTR(x), REF_TO_INT(PEEKVAL())); FILE *fd; if (trace_files) printf("About to open '%s'.\n", s); fd = fopen(s, arg_field == 3 ? READ_MODE : arg_field == 4 ? WRITE_MODE : APPEND_MODE); free(s); PEEKVAL() = ((fd == NULL) ? e_false : (ref_t) fd); } GOTO_TOP; case 6: /* fclose */ PEEKVAL() = BOOL_TO_REF( fclose((FILE *) PEEKVAL()) != EOF ); GOTO_TOP; case 7: /* fflush */ PEEKVAL() = BOOL_TO_REF( fflush((FILE *) PEEKVAL()) != EOF ); GOTO_TOP; case 8: /* putc */ POPVAL(x); y = PEEKVAL(); CHECKCHAR1(y, 2); PEEKVAL() = BOOL_TO_REF( putc(REF_TO_CHAR(y), (FILE *) x) != EOF); GOTO_TOP; case 9: /* getc */ { int c = getc((FILE *) PEEKVAL()); /* When possible, if an EOF is read from an interactive stream, the eof should be cleared so regular stuff can be read thereafter. */ if (c == EOF) { if (ISATTY((FILE *) PEEKVAL())) { if (trace_files) printf("Clearing EOF.\n"); clearerr((FILE *) PEEKVAL()); } PEEKVAL() = e_nil; } else PEEKVAL() = CHAR_TO_REF(c); } GOTO_TOP; case 10: /* check for interactiveness */ PEEKVAL() = ISATTY((FILE *) PEEKVAL())? e_t : e_nil; GOTO_TOP; case 11: /* tell where we are */ PEEKVAL() = INT_TO_REF(ftell((FILE *) PEEKVAL())); GOTO_TOP; case 12: /* set where we are */ POPVAL(x); { FILE *fd = (FILE *) x; long i = REF_TO_INT(PEEKVAL()); PEEKVAL() = fseek(fd, i, 0) == 0 ? e_t : e_nil; } GOTO_TOP; case 13: /* change working directory */ POPVAL(x); { char *s = oak_c_string((ref_t *) LOC_TO_PTR(x), REF_TO_INT(PEEKVAL())); PEEKVAL() = chdir(s) == 0 ? e_t : e_nil; free(s); } /* if there is no chdir() then use this: */ /* PEEKVAL() = e_nil; */ GOTO_TOP; default: printf("\nError (vm interpreter): " "bad stream primitive %d.\n", arg_field); UNLOCALIZE_ALL(); maybe_dump_world(333); exit(EXIT_FAILURE); GOTO_TOP; } case 32: /* FILLTAG n */ /* This implements CATCH/THROW */ x = PEEKVAL(); CHECKTAG0(x, PTR_TAG, 1); REF_SLOT(x, ESCAPE_OBJECT_VAL_OFF) = INT_TO_REF(VALUE_STACK_HEIGHT() - arg_field); REF_SLOT(x, ESCAPE_OBJECT_CXT_OFF) = INT_TO_REF(CONTEXT_STACK_HEIGHT()); GOTO_TOP; case 33: /* ^SUPER-CXT, ^SUPER-CXT-BR distance */ /* Analogous to FUNCALL-CXT[-BR]. */ POLL_SIGNALS(); PUSH_CONTEXT(signed_arg_field); /* Fall through to tail recursive case: */ goto super_tail; case 34: /* ^SUPER-TAIL */ /* Do not move this below the label! */ POLL_SIGNALS(); /******************/ super_tail: /******************/ /* No cache, no LAMBDA hack, things are easy. Maybe not looking at the lambda hack is a bug? On stack: type, operation, self, args... */ { ref_t the_type; ref_t y_type; ref_t meth_type; POPVAL(the_type); CHECKTAG1(the_type, PTR_TAG, e_nargs + 2); x = PEEKVAL(); /* The operation. */ CHECKTAG1(x, PTR_TAG, e_nargs + 2); CHECKVAL_POP(1); y = PEEKVAL_UP(1); /* Self. */ y_type = get_type(y); e_current_method = e_nil; find_method_type_pair(x, the_type, &e_current_method, &meth_type); if (e_current_method == e_nil) { if (trace_traps) printf("No handler for ^super operation.\n"); PUSHVAL(the_type); TRAP0(e_nargs + 2); } /* This could be dispensed with if meth_type has no ivars and isn't variable-length-mixin. */ { ref_t offset = lookup_bp_offset(y_type, meth_type); e_bp = REF_TO_PTR(y) + REF_TO_INT(offset); } } x = e_current_method; e_env = REF_TO_PTR(REF_SLOT(x, METHOD_ENV_OFF)); local_epc = CODE_SEG_FIRST_INSTR(e_code_segment = REF_SLOT(x, METHOD_CODE_OFF)); GOTO_TOP; #ifndef FAST default: printf("\nError (vm interpreter): " "Illegal parametric instruction %d\n", op_field); UNLOCALIZE_ALL(); maybe_dump_world(333); exit(EXIT_FAILURE); #endif } } } /* The above loop is infinite. We branch down to here when instructions fail, normally from tag traps, and then branch back. */ /*************/ intr_trap: /*************/ /* clear signal */ /*signal_poll_flag = 0;*/ if (signal_poll_flag) { /* We notify Oaklisp of the user trap by telling it that a noop instruction failed. The Oaklisp trap code must be careful to return nothing extra on the stack, and to restore NARGS properly. It is passed the old NARGS. */ /* the NOOP instruction. */ arg_field = op_field = instr = 0; signal_poll_flag = 0; #if ENABLE_TIMER } else if (timer_counter > TIMEOUT) { /* We notify Oaklisp of a timeout trap by telling it that an "alarm" instruction failed. This instruction, bound to arg_field 127, does not really exist. There is, however, a handler function bound to that trap. */ arg_field = 127; op_field = 0; instr = (127 << 8); timer_counter = 0; #endif } else { /* How did we get here? Just do a user trap to get to the debugger. */ arg_field = op_field = instr = 0; } #ifndef FAST if (trace_traps) printf("\nINTR: opcode %d, argfield %d.", op_field, arg_field); #endif /* Back off of the current intruction so it will get executed when we get back from the trap code. */ local_epc--; /* Pass the trap code the current NARGS. */ x = INT_TO_REF(e_nargs); trap_nargs = 1; /**************/ arg1_tt: /**************/ CHECKVAL_PUSH(3); PUSHVAL_NOCHECK(x); /*************/ arg0_tt: /*************/ #ifndef FAST if (trace_traps) { printf("\nTag trap: "); print_instr(op_field, arg_field, local_epc); printf("Top of stack: "); printref(stdout, PEEKVAL()); printf("\n"); } #endif /* Trick: to preserve tail recursiveness, push context only if next instruction isn't a RETURN and current instruction wasn't a FUNCALL. or a CHECK-NARGS[-GTE]. */ if ((op_field < 20 || op_field > 26 || op_field == 23) && local_epc[0] != (24 << 8)) PUSH_CONTEXT(0); /* Trapping instructions stash their argument counts here: */ /* see below */ if (op_field == 0) { /* argless instruction. */ PUSHVAL_NOCHECK(e_argless_tag_trap_table[arg_field]); e_nargs = trap_nargs; /* Set the instruction dispatch in case the FUNCALL fails. */ instr = (22 << 2); op_field = 22; arg_field = e_nargs; goto funcall_tail; } else { /* arg'ed instruction, so push arg field as extra argument */ PUSHVAL_NOCHECK(INT_TO_REF(arg_field)); PUSHVAL_NOCHECK(e_arged_tag_trap_table[op_field]); e_nargs = trap_nargs + 1; /* Set the instruction dispatch in case the FUNCALL fails. */ instr = (22 << 2); op_field = 22; arg_field = e_nargs; goto funcall_tail; } } oaklisp-1.3.3.orig/src/emulator/xmalloc.h0000664000175000000620000000267011036404255017315 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ #ifndef _XMALLOC_H_INCLUDED #define _XMALLOC_H_INCLUDED #include #include "data.h" extern bool isaligned(void *x); extern void *xmalloc(size_t size); extern void alloc_space(space_t * pspace, size_t size_requested); extern void free_space(space_t * pspace); extern void realloc_space(space_t * pspace, size_t size_requested); char *oak_c_string(ref_t * oakstr, int len); #endif oaklisp-1.3.3.orig/src/emulator/instr-data.c0000664000175000000620000000626011036617654017727 0ustar barakstaff// Automatically generated by instruction-table.oak char *argless_instr_name[] = { "NOOP", /* 0 */ "PLUS", "NEGATE", "EQ?", "NOT", "TIMES", "LOAD-GLO", "DIV", "=0?", "GET-TAG", "GET-DATA", /* 10 */ "CRUNCH", "GETC", "PUTC", "CONTENTS", "SET-CONTENTS", "LOAD-TYPE", "CONS", "<0?", "MODULO", "ASH", /* 20 */ "ROT", "STORE-BP-I", "LOAD-BP-I", "RETURN", "ALLOCATE", "ASSQ", "LOAD-LENGTH", "PEEK", "POKE", "MAKE-CELL", /* 30 */ "SUBTRACT", "=", "<", "BIT-NOT", "LONG-BRANCH", "LONG-BRANCH-NIL", "LONG-BRANCH-T", "LOCATE-BP-I", "LOAD-GLO-CON", "CAR", /* 40 */ "CDR", "SET-CAR", "SET-CDR", "LOCATE-CAR", "LOCATE-CDR", "PUSH-CXT-LONG", "CALL-PRIMITIVE", "THROW", "OBJECT-HASH", "OBJECT-UNHASH", /* 50 */ "GC", "BIG-ENDIAN?", "VLEN-ALLOCATE", "INC-LOC", "FILL-CONTINUATION", "CONTINUE", "REVERSE-CONS", "MOST-NEGATIVE-FIXNUM?", "FX-PLUS", "FX-TIMES", /* 60 */ "GET-TIME", "REMAINDER", "QUOTIENTM", "FULL-GC", "MAKE-LAMBDA", "GET-ARGLINE-CHAR", "ENABLE-ALARMS", "DISABLE-ALARMS", "RESET-ALARM-COUNTER", "MAKE-HEAVYWEIGHT-THREAD", /* 70 */ "TEST-AND-SET-LOCATIVE", "ILLEGAL-ARGLESS-72", "ILLEGAL-ARGLESS-73", "ILLEGAL-ARGLESS-74", "ILLEGAL-ARGLESS-75", "ILLEGAL-ARGLESS-76", "ILLEGAL-ARGLESS-77", "ILLEGAL-ARGLESS-78", "ILLEGAL-ARGLESS-79", "ILLEGAL-ARGLESS-80", /* 80 */ "ILLEGAL-ARGLESS-81", "ILLEGAL-ARGLESS-82", "ILLEGAL-ARGLESS-83", "ILLEGAL-ARGLESS-84", "ILLEGAL-ARGLESS-85", "ILLEGAL-ARGLESS-86", "ILLEGAL-ARGLESS-87", "ILLEGAL-ARGLESS-88", "ILLEGAL-ARGLESS-89", "ILLEGAL-ARGLESS-90", /* 90 */ "ILLEGAL-ARGLESS-91", "ILLEGAL-ARGLESS-92", "ILLEGAL-ARGLESS-93", "ILLEGAL-ARGLESS-94", "ILLEGAL-ARGLESS-95", "ILLEGAL-ARGLESS-96", "ILLEGAL-ARGLESS-97", "ILLEGAL-ARGLESS-98", "ILLEGAL-ARGLESS-99", "ILLEGAL-ARGLESS-100", /* 100 */ "ILLEGAL-ARGLESS-101", "ILLEGAL-ARGLESS-102", "ILLEGAL-ARGLESS-103", "ILLEGAL-ARGLESS-104", "ILLEGAL-ARGLESS-105", "ILLEGAL-ARGLESS-106", "ILLEGAL-ARGLESS-107", "ILLEGAL-ARGLESS-108", "ILLEGAL-ARGLESS-109", "ILLEGAL-ARGLESS-110", /* 110 */ "ILLEGAL-ARGLESS-111", "ILLEGAL-ARGLESS-112", "ILLEGAL-ARGLESS-113", "ILLEGAL-ARGLESS-114", "ILLEGAL-ARGLESS-115", "ILLEGAL-ARGLESS-116", "ILLEGAL-ARGLESS-117", "ILLEGAL-ARGLESS-118", "ILLEGAL-ARGLESS-119", "ILLEGAL-ARGLESS-120", /* 120 */ "ILLEGAL-ARGLESS-121", "ILLEGAL-ARGLESS-122", "ILLEGAL-ARGLESS-123", "ILLEGAL-ARGLESS-124", "ILLEGAL-ARGLESS-125", "ILLEGAL-ARGLESS-126", "ILLEGAL-ARGLESS-127", }; char *instr_name[] = { "ILLEGAL-ARGED-0", /* 0 */ "HALT", "LOG-OP", "BLT-STK", "BRANCH-NIL", "BRANCH-T", "BRANCH", "POP", "SWAP", "BLAST", "LOAD-IMM-FIX", /* 10 */ "STORE-STK", "LOAD-BP", "STORE-BP", "LOAD-ENV", "STORE-ENV", "LOAD-STK", "MAKE-BP-LOC", "MAKE-ENV-LOC", "STORE-REG", "LOAD-REG", /* 20 */ "FUNCALL-CXT", "FUNCALL-TAIL", "STORE-NARGS", "CHECK-NARGS", "CHECK-NARGS-GTE", "STORE-SLOT", "LOAD-SLOT", "MAKE-CLOSED-ENVIRONMENT", "PUSH-CXT", "LOCATE-SLOT", /* 30 */ "STREAM-PRIMITIVE", "FILLTAG", "^SUPER-CXT", "^SUPER-TAIL", }; oaklisp-1.3.3.orig/src/emulator/data.c0000664000175000000620000000503611036404255016561 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA /********************************************************************** * Copyright (c) by Barak A. Pearlmutter and Kevin J. Lang, 1987-99. * * Copyright (c) by Alex Stuebinger, 1998-99. * * Distributed under the GNU General Public License v2 or later * **********************************************************************/ /* This file contains many tunable parameters */ #define _REENTRANT #include "config.h" #include "data.h" #include "stacks.h" /* spaces */ space_t new_space, old_space, spatic; ref_t *free_point = 0; #ifndef THREADS /* stacks, including default buffer size & fill target */ oakstack value_stack = {1024, 1024/2}; oakstack context_stack = {512, 512/2}; #endif /* Virtual Machine registers */ #ifdef THREADS ref_t e_t, e_nil, e_fixnum_type, e_loc_type, e_cons_type, e_env_type, *e_subtype_table, e_object_type, e_segment_type, e_boot_code, *e_arged_tag_trap_table, *e_argless_tag_trap_table, e_uninitialized, e_method_type, e_operation_type = 0; size_t e_next_newspace_size; size_t original_newspace_size = 128 * 1024; #else ref_t *e_bp, *e_env, e_t, e_nil, e_fixnum_type, e_loc_type, e_cons_type, e_env_type, *e_subtype_table, e_object_type, e_segment_type, e_boot_code, e_code_segment, *e_arged_tag_trap_table, *e_argless_tag_trap_table, e_current_method, e_uninitialized, e_method_type, e_operation_type, e_process = 0; register_set_t *reg_set; size_t e_next_newspace_size; size_t original_newspace_size = DEFAULT_NEWSPACE * 1024; u_int16_t *e_pc; unsigned e_nargs = 0; #endif /* This should generally be defined in the Makefile */ #ifndef DEFAULT_WORLD #define DEFAULT_WORLD "/usr/lib/oaklisp/oakworld.bin" #endif char *world_file_name = DEFAULT_WORLD; char *dump_file_name = "oakworld-dump.bin"; int dump_base = 2; /* 2=binary, other=ascii */ bool dump_flag = false; int trace_gc = 0; oaklisp-1.3.3.orig/src/emulator/instr.c0000664000175000000620000000251011036617577017016 0ustar barakstaff// This file is part of Oaklisp. // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License as // published by the Free Software Foundation; either version 2 of the // License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // The GNU GPL is available at http://www.gnu.org/licenses/gpl.html // or from the Free Software Foundation, 59 Temple Place - Suite 330, // Boston, MA 02111-1307, USA #define _REENTRANT #include "data.h" #ifndef FAST #include #include "instr-data.c" void print_pc(u_int16_t *e_progc) { if (SPATIC_PTR((ref_t *) e_progc)) fprintf(stdout, "%7ld[spatic] ", (long)((char *)e_progc - (char *)spatic.start)); else fprintf(stdout, "%7ld[new ] ", (long)((char *)e_progc - (char *)new_space.start + 4 * spatic.size)); } void print_instr(int op_field, int arg_field, u_int16_t *e_progc) { print_pc(e_progc); if (op_field == 0) fprintf(stdout, "%s\n", argless_instr_name[arg_field]); else fprintf(stdout, "%s %d\n", instr_name[op_field], arg_field); } #endif oaklisp-1.3.3.orig/COPYING0000664000175000000620000004312707707543537014144 0ustar barakstaff GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. oaklisp-1.3.3.orig/Makefile0000664000175000000620000000143407725515164014537 0ustar barakstaff# This file is part of Oaklisp. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html # or from the Free Software Foundation, 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA .PHONY: all install clean all install clean: $(MAKE) -C src $@ $(MAKE) -C doc $@ $(MAKE) -C man $@ oaklisp-1.3.3.orig/README0000664000175000000620000000270707725515164013763 0ustar barakstaffThis is the Oaklisp source distribution. See http://www-bcl.cs.may.ie/~barak/oaklisp/ for updates. *** GETTING IT WORKING *** Oaklisp should be straightforward to install on a virgin machine. You need to compile some C source to make the emulator: make -C src/emulator install If you want the emulator to look for its world somewhere else, add eg CPPFLAGS='-DFAST -DDEFAULT_WORLD=\"/usr/local/lib/oaklisp/oakworld.bin\"' Then you need to put the recompiled binary world it will use in place: cp -a src/world/oakworld.bin /usr/local/lib/oaklisp/ (You can't just use "make -C src/world install" because a new world can't be built until Oaklisp is working, which requires a world to be installed. That's why the source distribution includes a pre-built oakworld.bin.) Now invoking /usr/local/bin/oaklisp should land you in an Oaklisp read-eval-print loop. *** INSTALLING DOCUMENTATION *** Probably you should make -C man install The language and implementation manuals are in doc/lang/lang.ps and doc/lim/lim.ps. They are latex source but include working Makefiles. You should be able to build and install them with make -C doc install *** BUILDING A NEW WORLD *** Note that Oaklisp is written in Oaklisp, so you must have a working Oaklisp before you can rebuild the Oaklisp world, which is done via make -C src/world In fact, you should be able to rebuild and reinstall *everything* via make install in this top-level directory. oaklisp-1.3.3.orig/doc/0002775000175000000620000000000011036654362013636 5ustar barakstaffoaklisp-1.3.3.orig/doc/oakman.bib0000664000175000000620000002305510752426034015562 0ustar barakstaff@article ( OAKLANG88 , author = "Kevin J. Lang and Barak A. Pearlmutter", title = "{O}aklisp: an Object-Oriented Dialect of {S}cheme", publisher = "Kluwer Academic Publishers", journal = "Lisp and Symbolic Computation", year = 1988, month = may, volume = 1, number = 1, pages = "39--51" ) @inproceedings ( CLOOPS, crossref = "OOPSLA86", author = "Danny Bobrow and others", title = "CommonLoops: Merging Common Lisp and Object-Oriented Programming", pages = "17--29" ) @manual ( FLAVORS2, key = "SYMBOLICS", title = "Symbolics Release 7 Documentation, Volume 2A", month = aug, year = 1986, organization = "Symbolics, Inc.", pages = "353--473" ) @book ( MVC, author = "Adele J. Goldberg and David Robson", title = "Smalltalk-80: The Language and its Implementation", publisher = "Addison-Wesley", year = 1983 ) @article ( R3RS, author = "Jonathan A. Rees and William Clinger and others", title = "The Revised$^3$ Report on the Algorithmic Language {S}cheme", journal = "SIGPLAN Notices", volume = 21, number = 12, year = 1986, month = dec, pages = "37--79" ) @techreport ( SCHEME-DECLARATIVE, author = "Guy L. {Steele Jr.}", title = "Lambda: the Ultimate Declarative", institution = "MIT AI Lab", year = 1976, number = "AI Memo 379" ) @techreport ( SCHEME-PAP, author = "Guy L. {Steele Jr.} and Gerald J. Sussman", title = "The Art of the Interpreter", institution = "MIT AI Lab", year = 1978, number = "AI Memo 453" ) @inproceedings ( SNYDER86, crossref = "OOPSLA86", author = "Alan Snyder", title = "Encapsulation and Inheritance in Object-Oriented Programming Languages", pages = "38--45" ) @inproceedings ( T, author = "Jonathan A. Rees and Norman I. {Adams, IV.}", title = "{T}: A Dialect of Lisp or, Lambda: the Ultimate Software Tool", booktitle = "ACM Symposium on Lisp and Functional Programming", year = 1982, month = aug ) @book ( T-MAN, author = "Jonathan A. Rees and others", title = "The {T} Manual", edition = "Fourth", year = 1984, publisher = "Yale University Computer Science Department" ) @inproceedings ( OAK-PAP, crossref = "OOPSLA86", author = "Kevin J. Lang and Barak A. Pearlmutter", title = "{O}aklisp: an Object-Oriented {S}cheme with First Class Types", pages = "30--37" ) @techreport ( 3LISP, author = "Brian Cantwell Smith", title = "Reflection and Semantics in Lisp", institution = "Center for the Study of Language and Information", year = 1984, number = "CSLI-84-8" ) @inproceedings ( FLAVORS1, crossref = "OOPSLA86", author = "David A. Moon", title = "Object-Oriented Programming with Flavors", pages = "1--8" ) @book ( CLtL, author = "Guy L. {Steele Jr}", title = "{C}ommon {L}isp: The Language", publisher = "Digital Press", year = 1984 ) @article ( MULTILISP85, author = "Robert H. Halstead", title = "Multilisp: A Language for Concurrent Symbolic Computation", publisher = "ACM", journal = "Transactions of Programming Languages and Systems", year = 1985, month = oct, volume = 7, number = 4, pages = "501--538" ) @techreport ( ACTORS78, author = "Baker, Jr., Henry G.", title = "Actor Systems for Real-Time Computation", number = "TR-197", institution = "MIT Laboratory for Computer Science", year = 1978, month = mar ) @phdthesis ( ORBIT, author = "David Kranz", title = "{O}rbit: An optimizing compiler for {S}cheme", school = "Yale University", year = 1988 ) @article ( ORBITa, author = "David Kranz and Richard Kelsey and Jonathan A. Rees and Paul Hudak and James Philbin and Norman I. Adams", title = "{O}rbit: An Optimizing Compiler for {S}cheme", journal = "SIGPLAN Notices Special Issue: Proceedings of the SIGPLAN 86 Symposium on Compiler Construction", volume = 21, number = 7, year = 1986, month = jul ) @article ( BAKER78, author = "H. G. Baker", title = "List Processing in Real Time on a Serial Computer", journal = cacm, publisher = "ACM", volume = 21, number = 4, pages = "280--294", year = 1978 ) @article ( FENICHEL-YOCHELSON69, author = "Robert R. Fenichel and Jerome C. Yochelson", title = "A Lisp Garbage Collector for Virtual Memory Computer Systems", journal = cacm, publisher = "ACM", volume = 12, number = 11, year = 1969, month = nov ) @article ( CITY-TRASH, title = "Software Helps City Plan Trash Pickup", journal = "Government Computer News", volume = 6, number = 18, year = 1987, month = sep, day = 11 ) @incollection ( PEARLMUTTER-LANG90A, crossref = "TALI91", author = "Barak A. Pearlmutter and Kevin J. Lang", title = "The Implementation of {O}aklisp", pages = "189--215" ) @manual ( ChineNual, author = "Daniel L. Weinreb and David A. Moon", title = "Lisp Machine Manual", year = 1981, month = jul, publisher = "MIT AI Lab", edition = "fourth" ) @article ( CHENEY70, author = "C. J. Cheney", title = "A Nonrecursive List Compacting Algorithm", journal = cacm, publisher = "ACM", volume = 13, number = 11, pages = "677--678", year = 1970 ) @incollection ( APPEL90, crossref = "TALI91", author = "Andrew Appel", title = "Garbage Collection", pages = "89--100" ) @incollection ( DETLEFS90, crossref = "TALI91", author = "David L. Detlefs", title = "Concurrent Garbage Collection for {C}++", pages = "101--134", note = "Also see thesis of same title, Carnegie Mellon University School of Computer Science technical report CMU-CS-90-119" ) @article ( PEARLMUTTER99, author = "Barak A. Pearlmutter", title = "Garbage collection with pointers to single cells", journal = cacm, publisher = "ACM", year = 1996, month = dec, volume = 39, number = 12, pages = "202--206", url = "http://www.acm.org/cacm/extension/pearlmt.pdf", Xnote = "Accepted Spring 1991" ) @article ( BLEFUSCU81, author = "Danny Cohen", title = "On Holy Wars and a Plea for Peace", journal = ieeetc, month = oct, year = 1981, page = "48--54" ) @comment( ******** Proceedings crossref'ed above ******** ) @proceedings (OOPSLA86, key = "OOPSLA-86", title = "ACM Conference on Object-Oriented Systems, Programming, Languages and Applications", booktitle = "ACM Conference on Object-Oriented Systems, Programming, Languages and Applications", month = sep, year = 1986, note = "Special issue of {\em SIGPLAN Notices}" ) @book (TALI91, title = "Topics in Advanced Language Implementation", booktitle = "Topics in Advanced Language Implementation", editor = "Peter Lee", publisher = "MIT Press", year = 1991 ) @Misc{OAKLISP-IMPLEMENTATION, author = "Barak A. Pearlmutter and Kevin J. Lang", title = "The {CMU} Implementation of {O}aklisp", howpublished = "Released under the GPL, available via ftp", year = 1986, note = "Most recent release: 1992, version 1.2. Accompanied by extensive language and implementation manuals. Under reasonably widespread use. Ports exist for Unix (most versions), AmigaDOS, MacOS, MS-DOS, Microsoft Windows, OS/2, CrayOS, and others. Influenced Apple's Dylan effort.", Xnote = "26,000 lines of code" } @Misc{CBP-SIMULATOR, author = "Barak A. Pearlmutter", title = "The {CBP} neural network simulator", howpublished = "Released under the GPL, available via ftp", year = 1987, note = "Flexible and powerful NN simulator. Facilities for weight sharing, backpropagation, mean-field Boltzmann machines, recurrent backpropagation, continuous time backpropagation through time, learnable time constants. Advanced stochastic optimization features. Interfaces to a number of graphical network display programs. User community of a few dozen." } @Misc{BAPLIBNN-SIMULATOR, author = "Barak A. Pearlmutter", title = "Subroutine library libnnembed", howpublished = "Released under the GPL", year = 1993, note = "Embeddable, flexible, efficient, convenient, portable NN simulator. Small footprint. Facilities for convolutional networks of various sorts, optimization via gradient methods or EM when applicable, able to build both modular architectures and hierarchical structures. Carefully modularized to avoid the problems that beset previous NN simulation libraries." } @Misc{LINUX-GC, author = "Barak A. Pearlmutter", title = "Garbage collector for the Linux kernel", howpublished = "Released under the GPL", year = 1995, note = "A special purpose garbage collector, part of Linux 2.0." } @comment{ Look these up: Slade, Stephen. The T programming language : a dialect of LISP / Stephen Slade. -- Englewood Cliffs, NJ : Prentice-Hall, c1987. Pointer swizzling: (address translation) at page fault time (Comp. Arch. News, June 1991) } oaklisp-1.3.3.orig/doc/lang/0002775000175000000620000000000011036654362014557 5ustar barakstaffoaklisp-1.3.3.orig/doc/lang/numhier.ips0000664000175000000620000002731207013612755016746 0ustar barakstaff%!PS-Adobe-2.0 EPSF-1.2 %%DocumentFonts: Times-Roman Times-Bold %%Pages: 1 %%BoundingBox: 5 604 300 788 %%EndComments 50 dict begin /arrowHeight 8 def /arrowWidth 4 def /none null def /numGraphicParameters 17 def /stringLimit 65535 def /Begin { save numGraphicParameters dict begin } def /End { end restore } def /SetB { dup type /nulltype eq { pop false /brushRightArrow idef false /brushLeftArrow idef true /brushNone idef } { /brushDashOffset idef /brushDashArray idef 0 ne /brushRightArrow idef 0 ne /brushLeftArrow idef /brushWidth idef false /brushNone idef } ifelse } def /SetCFg { /fgblue idef /fggreen idef /fgred idef } def /SetCBg { /bgblue idef /bggreen idef /bgred idef } def /SetF { /printSize idef /printFont idef } def /SetP { dup type /nulltype eq { pop true /patternNone idef } { /patternGrayLevel idef patternGrayLevel -1 eq { /patternString idef } if false /patternNone idef } ifelse } def /BSpl { 0 begin storexyn newpath n 1 gt { 0 0 0 0 0 0 1 1 true subspline n 2 gt { 0 0 0 0 1 1 2 2 false subspline 1 1 n 3 sub { /i exch def i 1 sub dup i dup i 1 add dup i 2 add dup false subspline } for n 3 sub dup n 2 sub dup n 1 sub dup 2 copy false subspline } if n 2 sub dup n 1 sub dup 2 copy 2 copy false subspline patternNone not brushLeftArrow not brushRightArrow not and and { ifill } if brushNone not { istroke } if 0 0 1 1 leftarrow n 2 sub dup n 1 sub dup rightarrow } if end } dup 0 4 dict put def /Circ { newpath 0 360 arc patternNone not { ifill } if brushNone not { istroke } if } def /CBSpl { 0 begin dup 2 gt { storexyn newpath n 1 sub dup 0 0 1 1 2 2 true subspline 1 1 n 3 sub { /i exch def i 1 sub dup i dup i 1 add dup i 2 add dup false subspline } for n 3 sub dup n 2 sub dup n 1 sub dup 0 0 false subspline n 2 sub dup n 1 sub dup 0 0 1 1 false subspline patternNone not { ifill } if brushNone not { istroke } if } { Poly } ifelse end } dup 0 4 dict put def /Elli { 0 begin newpath 4 2 roll translate scale 0 0 1 0 360 arc patternNone not { ifill } if brushNone not { istroke } if end } dup 0 1 dict put def /Line { 0 begin 2 storexyn newpath x 0 get y 0 get moveto x 1 get y 1 get lineto brushNone not { istroke } if 0 0 1 1 leftarrow 0 0 1 1 rightarrow end } dup 0 4 dict put def /MLine { 0 begin storexyn newpath n 1 gt { x 0 get y 0 get moveto 1 1 n 1 sub { /i exch def x i get y i get lineto } for patternNone not brushLeftArrow not brushRightArrow not and and { ifill } if brushNone not { istroke } if 0 0 1 1 leftarrow n 2 sub dup n 1 sub dup rightarrow } if end } dup 0 4 dict put def /Poly { 3 1 roll newpath moveto -1 add { lineto } repeat closepath patternNone not { ifill } if brushNone not { istroke } if } def /Rect { 0 begin /t exch def /r exch def /b exch def /l exch def newpath l b moveto l t lineto r t lineto r b lineto closepath patternNone not { ifill } if brushNone not { istroke } if end } dup 0 4 dict put def /Text { ishow } def /idef { dup where { pop pop pop } { exch def } ifelse } def /ifill { 0 begin gsave patternGrayLevel -1 ne { fgred bgred fgred sub patternGrayLevel mul add fggreen bggreen fggreen sub patternGrayLevel mul add fgblue bgblue fgblue sub patternGrayLevel mul add setrgbcolor eofill } { eoclip originalCTM setmatrix pathbbox /t exch def /r exch def /b exch def /l exch def /w r l sub ceiling cvi def /h t b sub ceiling cvi def /imageByteWidth w 8 div ceiling cvi def /imageHeight h def bgred bggreen bgblue setrgbcolor eofill fgred fggreen fgblue setrgbcolor w 0 gt h 0 gt and { l b translate w h scale w h true [w 0 0 h neg 0 h] { patternproc } imagemask } if } ifelse grestore end } dup 0 8 dict put def /istroke { gsave brushDashOffset -1 eq { [] 0 setdash 1 setgray } { brushDashArray brushDashOffset setdash fgred fggreen fgblue setrgbcolor } ifelse brushWidth setlinewidth originalCTM setmatrix stroke grestore } def /ishow { 0 begin gsave printFont findfont printSize scalefont setfont fgred fggreen fgblue setrgbcolor /vertoffset printSize neg def { 0 vertoffset moveto show /vertoffset vertoffset printSize sub def } forall grestore end } dup 0 3 dict put def /patternproc { 0 begin /patternByteLength patternString length def /patternHeight patternByteLength 8 mul sqrt cvi def /patternWidth patternHeight def /patternByteWidth patternWidth 8 idiv def /imageByteMaxLength imageByteWidth imageHeight mul stringLimit patternByteWidth sub min def /imageMaxHeight imageByteMaxLength imageByteWidth idiv patternHeight idiv patternHeight mul patternHeight max def /imageHeight imageHeight imageMaxHeight sub store /imageString imageByteWidth imageMaxHeight mul patternByteWidth add string def 0 1 imageMaxHeight 1 sub { /y exch def /patternRow y patternByteWidth mul patternByteLength mod def /patternRowString patternString patternRow patternByteWidth getinterval def /imageRow y imageByteWidth mul def 0 patternByteWidth imageByteWidth 1 sub { /x exch def imageString imageRow x add patternRowString putinterval } for } for imageString end } dup 0 12 dict put def /min { dup 3 2 roll dup 4 3 roll lt { exch } if pop } def /max { dup 3 2 roll dup 4 3 roll gt { exch } if pop } def /arrowhead { 0 begin transform originalCTM itransform /taily exch def /tailx exch def transform originalCTM itransform /tipy exch def /tipx exch def /dy tipy taily sub def /dx tipx tailx sub def /angle dx 0 ne dy 0 ne or { dy dx atan } { 90 } ifelse def gsave originalCTM setmatrix tipx tipy translate angle rotate newpath 0 0 moveto arrowHeight neg arrowWidth 2 div lineto arrowHeight neg arrowWidth 2 div neg lineto closepath patternNone not { originalCTM setmatrix /padtip arrowHeight 2 exp 0.25 arrowWidth 2 exp mul add sqrt brushWidth mul arrowWidth div def /padtail brushWidth 2 div def tipx tipy translate angle rotate padtip 0 translate arrowHeight padtip add padtail add arrowHeight div dup scale arrowheadpath ifill } if brushNone not { originalCTM setmatrix tipx tipy translate angle rotate arrowheadpath istroke } if grestore end } dup 0 9 dict put def /arrowheadpath { newpath 0 0 moveto arrowHeight neg arrowWidth 2 div lineto arrowHeight neg arrowWidth 2 div neg lineto closepath } def /leftarrow { 0 begin y exch get /taily exch def x exch get /tailx exch def y exch get /tipy exch def x exch get /tipx exch def brushLeftArrow { tipx tipy tailx taily arrowhead } if end } dup 0 4 dict put def /rightarrow { 0 begin y exch get /tipy exch def x exch get /tipx exch def y exch get /taily exch def x exch get /tailx exch def brushRightArrow { tipx tipy tailx taily arrowhead } if end } dup 0 4 dict put def /midpoint { 0 begin /y1 exch def /x1 exch def /y0 exch def /x0 exch def x0 x1 add 2 div y0 y1 add 2 div end } dup 0 4 dict put def /thirdpoint { 0 begin /y1 exch def /x1 exch def /y0 exch def /x0 exch def x0 2 mul x1 add 3 div y0 2 mul y1 add 3 div end } dup 0 4 dict put def /subspline { 0 begin /movetoNeeded exch def y exch get /y3 exch def x exch get /x3 exch def y exch get /y2 exch def x exch get /x2 exch def y exch get /y1 exch def x exch get /x1 exch def y exch get /y0 exch def x exch get /x0 exch def x1 y1 x2 y2 thirdpoint /p1y exch def /p1x exch def x2 y2 x1 y1 thirdpoint /p2y exch def /p2x exch def x1 y1 x0 y0 thirdpoint p1x p1y midpoint /p0y exch def /p0x exch def x2 y2 x3 y3 thirdpoint p2x p2y midpoint /p3y exch def /p3x exch def movetoNeeded { p0x p0y moveto } if p1x p1y p2x p2y p3x p3y curveto end } dup 0 17 dict put def /storexyn { /n exch def /y n array def /x n array def n 1 sub -1 0 { /i exch def y i 3 2 roll put x i 3 2 roll put } for } def %%EndProlog %I Idraw 5 Grid 4 %%Page: 1 1 Begin %I b u %I cfg u %I cbg u %I f u %I p u %I t [ 0.9 0 0 0.9 0 0 ] concat /originalCTM matrix currentmatrix def Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -142.407 117 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -51.4066 117 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -92.4066 162 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -42.4066 207 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -242.407 27 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -151.407 27 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -192.407 72 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -101.407 72 ] concat %I 324 657 45 9 Elli End Begin %I Line %I b 65535 1 0 1 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 -1 -66 1431 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 0 1 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 -1 -116 1386 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 0 1 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 -1 -166 1341 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 0 1 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 -1 -16 1476 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 1 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 1 -120 162 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 1 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 1 -220 72 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 1 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 1 -170 117 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 1 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 1 -70 207 ] concat %I 297 648 279 621 Line End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-medium-r-*-120-* /Times-Roman 12 SetF %I t [ 1 0 0 1 231.049 871 ] concat %I [ (number) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-medium-r-*-120-* /Times-Roman 12 SetF %I t [ 1 0 0 1 190.049 826 ] concat %I [ (real) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-medium-r-*-120-* /Times-Roman 12 SetF %I t [ 1 0 0 1 130.549 781 ] concat %I [ (rational) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-bold-r-*-140-* /Times-Bold 14 SetF %I t [ 1 0 0 1 226.049 781.5 ] concat %I [ (float) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-bold-r-*-140-* /Times-Bold 14 SetF %I t [ 1 0 0 1 166.049 736.5 ] concat %I [ (fraction) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-medium-r-*-120-* /Times-Roman 12 SetF %I t [ 1 0 0 1 82.0494 736 ] concat %I [ (integer) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-bold-r-*-140-* /Times-Bold 14 SetF %I t [ 1 0 0 1 28.0495 691.5 ] concat %I [ (fixnum) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-bold-r-*-140-* /Times-Bold 14 SetF %I t [ 1 0 0 1 117.549 691.5 ] concat %I [ (bignum) ] Text End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -1.4066 162 ] concat %I 324 657 45 9 Elli End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-bold-r-*-140-* /Times-Bold 14 SetF %I t [ 1 0 0 1 264.049 826.5 ] concat %I [ (complex) ] Text End End %I eop showpage %%Trailer end oaklisp-1.3.3.orig/doc/lang/sides.tex0000664000175000000620000000706607725515165016426 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Side Effects} \label{sides} The treatment of side effects in Oaklisp is modelled on that of T. The salient feature of this approach is the use of reversible access procedures to perform side effects on composite data structures and anonymous storage cells. \section{Assignment} Side effects on variables and objects are performed with the \df{set\protect\bang} special form, which combines the functionality of the \df{setq} and \df{setf} forms found in other Lisps. \sform{set\protect\bang}{location new-value} \doc{Changes the value of \emph{location} to \emph{new-value}, which is then returned as the value of the expression. If \emph{location} is a symbol, then it is interpreted as a variable name. The variable must have been previously defined in some lexical binding contour or locale. If \emph{location} is a list, then it is interpreted as a reference to a settable access operation. For example, \texttt{(set! (car foo) 'bar)} means the same thing as \texttt{(rplaca foo 'bar)} in Common Lisp.} \lo{setter}{operation} \doc{Takes a settable access operation and returns the corresponding alteration operation.} \section{Locatives} \df{locative} is an Oaklisp type that is similar to the pointer types found in procedural languages such as C or Pascal. Locatives are created and dereferenced by the following constructs. \sform{make-locative}{location} \doc{Returns a locative that points to \emph{location}, which must be a variable or a list with the form of a call on a locatable access operation.} \lo{locater}{operation} \doc{Takes a locatable access operation and returns the corresponding locative-making operation.} \lo{contents}{locative} \doc{Returns the contents of the location which is referenced by \emph{locative}. Since \df{contents} is a settable operation, side effects can be performed on locations through locatives. For example, \texttt{(set! (contents (make-locative (car \emph{foo}))) '\emph{bar})} has the same effect as \texttt{(set! (car \emph{foo}) '\emph{bar})}.} \section{Operation Types} Since operations are objects, they are classified into types according to the operations which can be performed on them. The types discussed here can generate side-effecting operations from access operations. \ty{operation} \doc{This is the generic operation type that is a component of all other operation types.} \ty{settable-operation} \doc{An access operation is settable if side effects can be performed through it. Settable operations respond to \df{setter}.} \ty{locatable-operation} \doc{An access operation is locatable if it retrieves information from a single physical location. Locatable operations respond to \df{setter} and \df{locater}.} \section{Modification Forms} See chapter 6 of {\it The T Manual} for a description of the following forms. \sform{swap}{location new-value} \sform{modify}{location procedure} \sform{modify-location}{location continuation} oaklisp-1.3.3.orig/doc/lang/methods.tex0000664000175000000620000002100510752406631016736 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Methods and Scoping} \label{methods} In chapter \ref{types}, the concept of {\it type} was discussed. The assertion was made that operation methods lie at the heart of the typing system, because they determine the behavior of objects. This chapter describes the mechanism for defining methods. \section{Methods} A table of methods is maintained in the descriptor of every type. At run-time, these tables are searched to find the methods which are used to handle operations on objects. The only mechanism for manipulating method tables is the following side-effecting special form. \sform{add-method}{\lpar operation $[$\lpar type \dt ivar-list\rpar$]$ \dt arg-list\rpar \dt body} \doc{Adds a method for \emph{operation} to the method table of \emph{type}. If a method for \emph{operation} already exists, it is replaced. The value returned by \df{add-method} is \emph{operation}.} The body of the form is surrounded by an implicit \df{block}. The arguments to the method are specified by \emph{arg-list}. Since the first argument is always the object handling the message, a useful convention is to call it \df{self}. Instance variables of \emph{type} can be referenced in the body if they are declared in \emph{ivar-list}. Instance variables of supertypes may not be referenced in any case. Naming conflicts between instance variables and arguments are resolved by the rule that the variables in \emph{arg-list} shadow instance variables that have the same names. Oaklisp closes methods over free variable references at compile-time, thereby solving the upward funarg problem and allowing procedures to share state in a controlled manner. \section{Scoping} Oaklisp is a lexically scoped language in which all variable references are resolved at compile-time. When a variable reference is encountered, the compiler searches outwards from that point through the nested lexical binding contours until it finds a declaration for the variable.\footnote{If a declaration isn't found, the compiler proceeds to look for the variable in the appropriate locale. See chapter \ref{locales}.} We have already seen one mechanism for introducing new lexical contours: the argument list of the \df{add-method} special form. Oaklisp provides several other forms which can be used to define local variables and procedures. \sform{let} {\lpar\lpar var$_1$ val$_1$\rpar\ldots var$_n$ val$_n$\rpar \dt body} \doc{Evaluates \emph{body} in an environment where the $n$ variables are bound to the $n$ values. The value returned is that of \emph{body}.} \sform{let*} {\lpar\lpar var$_1$ val$_1$\rpar\ldots var$_n$ val$_n$\rpar \dt body} \doc{This form is similar to \df{let}. The difference is that \df{let} performs the bindings simultaneously whereas \df{let*} performs the bindings sequentially so that each value expression can refer to the preceding variables.} \sform{labels} {\lpar\lpar var$_1$ val$_1$\rpar\ldots\lpar var$_n$ val$_n$\rpar\rpar \dt body} \doc{\df{labels} differs from \df{let} in that the value expressions are evaluated in a binding environment in which all of the variables are already defined. This facilitates the definition of mutually recursive procedures.} \section{Functional Syntax} Sometimes it is convenient to adopt a more conventional Lisp viewpoint while designing programs. This viewpoint considers functions to be the primary programming abstraction, with objects downgraded to the status of data which is passed around between functions. The key to this programming style is the ability to write functions which can accept arguments of any type. Oaklisp readily accommodates the functional programming style, since methods can be defined for the type \df{object}, which is the supertype of all other types. In fact, if the type specifier is omitted in an \df{add-method} form, the type \df{object} is assumed. Thus, \texttt{(add-method (\mbox{cons-1} x) (cons x 1))} defines a method that is valid for any type. To give the language a more familiar appearance when this programming style is used, the following macros are also provided. \mc{lambda}{arg-list \dt body} \doc{\macdef{}{(add-method ((make operation) . \emph{arg-list}) . \emph{body})}} \mc{define}{\lpar variable \dt arg-list\rpar \dt body} \doc{\macdef{}{(define \emph{variable} (lambda \emph{arg-list} . \emph{body}))}} \section{Dispatching to Supertypes} Sometimes a method doesn't want to override the inherited method completely, but rather wishes only to modify or extend its behaviour. For instance, imagine that the type \texttt{dog} has a method so that the \texttt{notice-stranger} operation causes it to run around, jump up and down, bark, and return the amount of time wasted. Say that \texttt{stupid-dog} is a subtype of \texttt{dog} defined by \texttt{(define-instance stupid-dog type '() (list dog))}, and that we want stupid dogs to behave just like regular dogs in response to a \texttt{see-stranger} message, except that they do it twice. This could be accomplished without the duplication of code by dispatching to the supertype twice, as in the following code fragment. \begin{flushleft}\tt (add-method (see-stranger (stupid-dog) self stranger)\\ ~~(+ ({\upar}super dog see-stranger self stranger)\\ ~~~~~({\upar}super dog see-stranger self stranger))) \end{flushleft} \op{{\protect\upar}super}{type operation self \dt args} \doc{This is just like \texttt{(\emph{operation self \dt args})} except that the method search begins at \emph{type} rather than at the type of \emph{self}. It is required that \emph{type} be an immediate supertype of the type that the method this call appears in is added to, although our current implementation does not yet enforce this restriction. \df{{\protect\upar}super} is analogous to the Smalltalk-80 \index{Smalltalk-80} mechanism of the same name, except that due to Oaklisp's multiple inheritance it is necessary for the programmer to explicitly state which supertype is to be dispatched to.} \section{Rest Args} When a method is defined with a parameter list that is improper (\ie\ dotted) the method is permitted to receive extra values in addition to its regular parameters at run time. These values are associated with the pseudo variable name that appears after the dot, which will henceforth be called the rest name. Unlike a real variable name, a rest name can't be evaluated and can only be referred to in two places: at the end of a function call that uses dotted syntax (which signifies that the extra values should be passed on to the function being called), and in a \df{rest-length} form, which is the mechanism for finding out how many rest args a method has been passed. \sform{rest-length}{rest-name} \doc{Yields the number of extra values that were received by the method in which \df{rest-name} is declared.} Rest args can never be accessed directly, but must be passed tail recursively to other functions. In fact, a function is not permitted to return without disposing of its rest args. Usually a function that takes a variable number of arguments will recurse on itself or on a helper function, consuming its arguments one by one until they are all gone, at which point the function is free to return. The following functions have been provided to make it easier to write a function definition that satisfies all of the rules for rest args. \op{consume-args}{val \dt args} \doc{Returns \emph{val} after consuming \emph{args}.} \op{listify-args}{op \dt args} \doc{Calls \emph{op} on a list consisting of the values of \emph{args}.} A call to \df{listify-args} can be used as the body of a method definition as a means of trivially satisfying the rest arg rules. When using this technique, \emph{op} is a lambda that performs all of the computation for the method. The rest args of the method are wrapped up in a list that is passed in as the lambda's one parameter, and the regular parameters and instance variables of the method are available inside the lambda because of lexical scoping. oaklisp-1.3.3.orig/doc/lang/dynamic.tex0000664000175000000620000003030307725515164016730 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Dynamic State} \label{dynamic} As Steele and Sussman pointed out in \emph{The Art of the Interpreter}, dynamic scoping provides the most natural decomposition of state in certain situations. This chapter describes the Oaklisp facilities for creating and manipulating state that has dynamic extent. \section{Fluid Variables} \discuss{To avoid the problems that arise when fluid variables are integrated with the lexical environment, Oaklisp fluid variables have been placed in a completely separate dynamic environment. Fluid variables don't even look like lexical variables, since they can only be referenced using the \df{fluid} special form. The mechanism for creating fluid variables is \df{bind}, which syntactically resembles \df{let}.} \sform{bind}{\lpar\lpar\texttt{fluid} var$_1$\rpar val$_1$\rpar\ldots\lpar\lpar\texttt{fluid} var$_n$ val$_n$\rpar\dt body} \doc{Evaluates \emph{body} in a dynamic environment where the $n$ symbols are bound to the $n$ values.} \sform{fluid}{symbol} \doc{Returns the value of the fluid variable \emph{symbol}. Even though \df{fluid} is a special form, it is settable, so \texttt{(set! (fluid \emph{symbol}) \emph{value})} changes the value of the fluid variable \emph{symbol} to \emph{value}. The reader will read \texttt{foo} preceded by a control-v character as \texttt{(fluid foo)}; this was motivated by the fact that control-v prints as $\bullet$ on both Macintosh$^{\mbox{tm}}$ and Symbolics computers.} \section{Non-local Exits} \label{sec:nonlocal} \discuss{Most Lisp dialects include some sort of \df{catch} facility for performing non-local exits. Oaklisp provides two facilities at varying points on the generality vs.\ cost spectrum.} \op{call-with-current-continuation}{operation} \doc{Calls \emph{operation} with one argument, the current continuation. The synonym \df{call/cc} is provided for those who feel that \df{call-with-current-continuation} is excessively verbose.} \index{\texttt{call/cc}|see \texttt{call-with-current-continuation}} \sform{catch}{variable \dt body} \doc{\emph{variable} is lexically bound to an escape operation that may be called from anywhere within \emph{body}'s dynamic extent. If \emph{variable} is not called, \df{catch} yields the value of \emph{body}. This is implemented in such a way that \emph{body} is called tail recursively.} \sform{native-catch}{variable \dt body} \doc{\emph{variable} is lexically bound to an escape tag that may be thrown from anywhere within \emph{body}'s dynamic extent. If \emph{variable} is not thrown to, \df{native-catch} yields the value of \emph{body}. This is implemented in such a way that \emph{body} is called tail recursively.} \op{throw}{tag value} \doc{Causes execution to resume at the point specified by \emph{tag}. This point is always a \df{native-catch} expression, which immediately yields \emph{value}. Cleanup actions specified with \df{wind-protect} are performed while the stack is being unwound.} \sform{wind-protect}{before form after} \doc{\macdef{} {(dynamic-wind (lambda () \emph{before}) (lambda () \emph{form}) (lambda () \emph{after}))}} \sform{funny-wind-protect}{before abnormal-before form after abnormal-after} \doc{A \df{wind-protect} evaluates \emph{before}, \emph{form}, and \emph{after}, returning the value of \emph{form}. If \emph{form} is entered or exited abnormally (due to \df{call/cc} or \df{catch}) the \emph{before} and \emph{after} forms, respectively, are automatically executed. \df{funny-wind-protect} is the same except that different guard forms are evaluated depending on whether the dynamic context is entered or exited normally or abnormally.} \op{dynamic-wind}{before-op main-op after-op} \doc{Calls the operation \emph{before-op}, calls the operation \emph{main-op}, calls the operation \emph{after-op}, and returns the value returned by \emph{main-op}. If \emph{main-op} is exited abnormally, \emph{after-op} is called automatically on the way out. Similarly, if \emph{main-op} is entered abnormally, \emph{before-op} is called automatically on the way in.} % \sform{unwind-protect}{form \dt unwind-forms} % \doc{Acts like \df{block}, except that the \emph{unwind-forms} are % guaranteed to execute even if a throw occurs out of \emph{form}. This % construct is implemented tail-recursively, and there is no restriction on % throws from the \emph{unwind-forms}.} % % \sform{unwind-protect0}{form \dt unwind-forms} % \doc{Acts like \df{unwind-protect}, except that it yields % the value of \emph{form}, and does not permit a tail-recursive % implementation.} \section{Error Resolution} \label{errors} \discuss{{\bf Note:} the error system is not stable, and will probably evolve towards the Common Lisp error system, which has a number of good ideas.} Programs interact with the error system in three ways: they signal various sorts of errors (typically throwing the user into the debugger), they provide restart handlers that the user can invoke (using \df{ret}) to escape from the debugger, and they provide handlers to be invoked when various types of errors occur. \subsection{Signaling Errors} Errors are signalled using the following operations. \op{warning}{format-string \dt format-args} \doc{Prints out the message specified by \emph{format-string} and \emph{format-args} and continues execution.} \op{error}{format-string \dt format-args} \doc{This signals \df{generic-fatal-error}, which normally has the effect of printing out the error message specified by \emph{format-string} and \emph{format-args} and dumping the user into a subordinate read-eval-print loop.} \op{cerror}{continue-string format-string \dt format-args} \doc{This signals \df{generic-proceedable-error}, which normally has the effect of printing the error message specified by \emph{format-string} and \emph{format-args} and dumping the user into a subordinate read-eval-print loop in which there is a restart handler that continues the computation by returning a user specified value from \df{cerror}. \emph{Continue-string} is the text associated with this handler when it is listed as an option by the subordinate evaluator.} \subsection{Restart Handlers} There are two special forms that programs can use to define more complex restart handlers than just returning from the call to \df{cerror}. The simpler of the two is \df{error-return}, which is similar to \df{catch} in that it can be forced to return a value before its body has been fully evaluated. This form is used in the definition of \df{cerror}. \mc{error-return}{string \dt body} \doc{Evaluates \emph{body} in a dynamic context in which a restart handler is available that can force the form to return. The handler is identified by \emph{string} in the list of choices the debugger presents to the user. If the handler is invoked by calling \df{ret} with an argument in addition to the handler number, the \df{error-return} form returns this value; otherwise it returns \df{\#f}. If no error occurs, \df{error-return} yields the value of \emph{body}.} The second special form acts just like a \df{let} unless an error occurs, in which case an error handler is available that re-executes the body of the form after (possibly) rebinding the lexical variables specified at the top of the form. \mc{error-restart}{string \texttt{((}var$_0$ val$_0$\texttt{)}\ldots\texttt{)} \dt body} \doc{Evaluates \emph{body} in a dynamic context in which a restart handler is available that can force the re-evaluation of the body with new values for \emph{var$_0$ \ldots}. These new values are specified as additional arguments to \df{ret}. If there are not enough arguments to \df{ret}, the remaining variables are left at their previous values. The handler is identified by \emph{string} in the list of choices printed by the debugger. If no error occurs, \df{error-restart} yields the value of \emph{body}.} \subsection{Error Handlers} Oaklisp uses its type system to govern the resolution of errors. The top-level environment contains a hierarchy of types which characterizes every error that can occur. When an error condition arises, the appropriate type is instantiated, and an error resolution operation is performed on the new object. This operation is performed by a method that deals with the error in a manner consistent with its type. There are clearly better ways of dealing with some errors than invoking the debugger. A variety of methods have been written to deal with the most common errors. For example, there are \df{proceed} methods for simple arithmetic traps which substitute a program specified value for that of the failed computation. The use of \df{proceed} and other error resolution operations is prescribed by the following special form. \mc{bind-error-handler} {\lpar\lpar err$_1$ op$_1$\rpar\ldots\lpar err$_n$ op$_n$\rpar\rpar\dt body} \doc{Evaluates \emph{body} in a dynamic environment where the $n$ error types have been associated with the $n$ error resolution operations. When an error occurs, the current list of condition bindings is searched to find an operation to perform. An operation associated with a supertype of the actual error type will be selected if it is encountered on the list. If a suitable operation cannot be found, the default operation \df{invoke-debugger} is performed.} \subsection{Operations on Errors} There are a number of operations that can be invoked on error objects in error handlers. \op{report}{error stream} \doc{Instructs \emph{error} to print a descriptive message to \emph{stream}.} \op{invoke-debugger}{error} \doc{This is the default error resolution operation. It is performed on all errors unless it is explicitly overridden.} \op{proceed}{error \dt values} \doc{Attempts to continue from the error, eg.\ a file system error would retry the failed operation. The \emph{values} have semantics determined by the precise type of error. For instance, continuing a failed attempt to open a file with a value might instruct the system to try a new filename.} \op{remember-context}{error after-operation} \doc{Instructs \emph{error} to salt away the current continuation and then call \emph{after-operation}, which should never return.} \op{invoke-in-error-context}{error operation} \doc{Invokes \emph{operation} on \emph{error} after moving back to the context of the error if its been salted away.} \subsection{Error Types} There are a plethora of error types defined in Oaklisp. \ty{general-error} \doc{This is the top of the error type hierarchy. An operation defined for \df{general-error} can be used to resolve any error.} \ty{generic-fatal-error} \doc{Signaled by \df{error}.} \makin{proceedable-error}{message} \doc{Uses \emph{message} in composing its report.} \ty{generic-proceedable-error} \doc{Signaled by \df{cerror}.} \ty{error-opening} \doc{Various subtypes of this are signaled when various types of error while opening files occur.} \ty{read-error} \doc{Subtypes of this are signaled when \df{read} sees malformed or truncated input.} \ty{unexpected-eof} \doc{This subtype of \df{read-error} is signaled when the reader comes to the end of a file unexpectedly.} \discuss{{\bf Work for idle hands:} Many types of errors have yet to be implemented. For example, domain errors in arithmetic functions generally call \df{error} rather than signaling some special variety of error, template mismatch in the \df{destructure*} macro should signal some special type of error rather than calling \df{cerror}, etc. Basically, most calls to \df{error} and \df{cerror} in system level code should be replaced with \df{signal}, and appropriate ideosyncratic types of errors should be defined, thereby giving users more precise control over what types of system level errors to handle.} oaklisp-1.3.3.orig/doc/lang/misc.tex0000664000175000000620000000710007725515164016236 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Miscellaneous} \label{misc} \section{Tables} The types are \df{generic-hash-table} and \df{eq-hash-table}. The access interface is \df{present?}, which returns a \df{pair} whose \df{car} is the key and whose \df{cdr} is the associated value. A different interface to hash tables is provided by the T-style \df{table-entry} operation which returns the associated value or \df{\#f} if the key isn't in the table. The setter of either operation can be used to add, modify, and remove associations. \makin{generic-hash-table}{key-hash-op equal-op} \makin{eq-hash-table}{} \so{present?}{table key} \doc{Returns \texttt{(\emph{key \dt val})} pair, or \df{\#f} if not present.} \so{table-entry}{table key} \doc{Returns value indexed by \emph{key} or \df{\#f} if not present.} \section{Delays} Oaklisp's delays are compatible with the facility defined in R3RS, but extend those primitive facilities in two ways. First, the system will automatically force promises when appropriate. For instance, \texttt{(+ 2 (delay 3))} does not signal an error; it returns \texttt{5}. Similarly, delays are printed transparently, slightly violating read/print consistency. Secondly, the delay facility is user extensible. Users can create new kinds of delays that have special protocols, for instance numeric delays that do not force themselves upon arithmetic operations, but instead make more and more complicated delays. \sform{delay}{expression} \doc{This immediately returns a \emph{promise} for \emph{expression}, without actually computing \emph{expression}. This promise does not compute \emph{expression} until it is forced, at which point it returns the value of \emph{expression}, computing it if it hasn't already done so.} \op{force}{x} \doc{If \emph{x} is a promise, it is forced to compute its value, which is returned. If \emph{x} is not a promise, it itself is returned.} \ty{promise} \doc{This is the type of the objects returned by \df{delay}.} \ty{forcible} \doc{This is an abstract type, of which \df{promise} is a concrete subtype. Subtypes of \df{forcible} are expected to respond to the \df{force} operation in a sensible fashion. Oaklisp's system internals sometimes force instances of \df{forcible} automatically, for instance when sending them messages for which no appropriate method can otherwise be found.} \fv{forcible-print-magic} \doc{Controls how delays are printed. This is how \texttt{(delay 'foo)} would print under various settings of \texttt{forcible-print-magic}. \begin{center} \begin{tabular}{|l|l|}\hline value & print style \\ \hline \texttt{\#f} & \texttt{\#} \\ \texttt{indicate} & \texttt{\#[DELAY FOO 3462]} \\ \texttt{transparent} & \texttt{FOO} \\ \hline \end{tabular} \end{center} The default is \df{transparent}. A setting of \df{indicate} is more instructive if you encounter odd behavior that might be due to delays.} oaklisp-1.3.3.orig/doc/lang/control.tex0000664000175000000620000001022611036617630016755 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Control} \label{control} Nonlocal control constructs like \df{call/cc} are described in section \ref{sec:nonlocal}. \discuss{Since control structures are not a very interesting issue, we followed existing Lisp dialects closely when designing this aspect of Oaklisp. Every control structure in this chapter does just what you would expect.} \section{Simple Constructs} These forms are compatible with both T \citep[chapter 5]{T-MAN} and the Scheme standard \citep{R3RS}. \sform{cond}{\dt clauses} \doc{The \emph{clauses} are run through sequentially until one is selected. Each clause can be of four possible forms. \emph{\lpar test \dt body\rpar} evaluates \emph{body} if \emph{test} is true. \emph{\lpar\df{else} \dt body\rpar} always evaluates \emph{body}, and if present must be the last clause. \emph{\lpar test \texttt{=>} operation\rpar} calls \emph{operation} on the result of \emph{test} if the result of evaluating \emph{test} was not \emph{false}. \emph{\lpar test\rpar} is equivalent to \emph{\lpar test \texttt{=> identity}\rpar}.} \sform{if}{test consequent $[$alternate$]$} \pr{not}{object} \sform{and}{\dt tests} \sform{or}{\dt tests} \sform{iterate}{variable specs \dt body} \sform{block}{\dt body} \doc{Evaluates the forms of \emph{body} sequentially, returning (tail recursively) the value of the last one.} \sform{block0}{form \dt body} \doc{\meq{}{(let ((x \emph{form})) (block \dt \emph{body}) x)}} \sform{dotimes}{\lpar variable number $[$rform$]$\rpar \dt body} \doc{\meq{}{(let ((x (lambda (\emph{variable}) \dt \emph{body}))) (map x (iota \emph{number})) \emph{rform})}} \sform{dolist}{\lpar variable list $[$rform$]$\rpar \dt body} \doc{\meq{}{(let ((x (lambda (\emph{variable}) \dt \emph{body}))) (map x \emph{list}) \emph{rform})}} \sform{dolist-count}{\lpar variable list count-var\rpar \dt body} \doc{Just like \texttt{dolist} except that \emph{count-var} gives the count of the current element in the list, starting at zero.} \sform{while}{condition \dt body} \doc{\meq{}{(let ((q (lambda () \emph{test}))(x (lambda () \dt \emph{body}))) (iterate aux () (cond ((\emph{q}) (\emph{x}) (aux)))))}} \sform{unless}{test \dt body} \doc{\meq{}{(cond ((not \emph{test}) \dt \emph{body}))}} \sform{do}{\lpar \lpar var initial step \rpar \ldots \rpar \lpar termination-test \dt termination-body \rpar \dt body} \doc{\meq{}{(iterate aux ((\emph{var initial}) \ldots) (cond (\emph{termination-test} \dt \emph{termination-body}) (else (block \dt \emph{body}) (aux \emph{step} \ldots))))}} \section{Mapping Constructs} \label{sec:controlmap} Although these can be used as control constructs, they can also be thought of as ways to manipulate data structures. \df{map} maps an operation over some sequences generating a sequence of results. \df{for-each}, which doesn't save the results, is used when the operation is called for effect only. For all of these, the order of evaluation is undefined; the system may apply the operation to the various elements of the sequence in any order it desires. \op{map}{operation \dt sequences} \op{mapcdr}{operation \dt lists} \doc{Applies \emph{operation} to successive ``cdrs'' rather than to elements, and returns a list of the returned values.} \op{for-each}{operation \dt sequences} \op{for-each-cdr}{operation \dt lists} \doc{Like \df{mapcdr} but for effect only.} \op{map\protect\bang}{operation \dt sequences} \doc{Like \df{map}, except that the retuned values are destructively placed into the successive storage locations of the first \emph{sequence}.} oaklisp-1.3.3.orig/doc/lang/types.tex0000664000175000000620000002366507725515165016466 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Types and Objects} \label{types} Oaklisp is an object-oriented language which is organized around the concept of {\it type}. The type of an object determines its behavior when operations are performed on it. To permit the modular specification of types with complex behaviors, a type is allowed to have multiple supertypes. There is no distinction in Oaklisp between predefined system types and user-defined types. A type specifies the behavior of an object by providing methods that are used to perform operations on that object. Because methods are inherited from supertypes, a subtype only needs to supply those methods which are required to distinguish itself from the more general types. A method defined for a given type pre-empts any inherited methods for the same operation. Instance variables are the mechanism for keeping state in objects. Every object possesses a data structure where the values of its instance variables are stored. Although each object contains storage for all of the instance variables required by its type and supertypes, methods for a given type can only refer to instance variables defined in that type. In particular, methods cannot refer to instance variables that are defined in supertypes. It is possible to think of Oaklisp in terms of messages that are being passed to objects, rather than in terms of operations that are being performed on objects. The latter view was chosen because it is more consistent with Lisp syntax and semantics. \section{Fundamental Types} There are two important relations in the Oaklisp type system: {\it is-a} and {\it subtype}. An object is related to its type by the relation {\it is-a}, and a type is related to its supertypes by the relation {\it subtype}. Each of these relations defines a tree structure which includes all of the objects in the system. The most fundamental types in the system are \df{type} and \df{object}. They are distinguished by their position at the top of the {\it is-a} and {\it subtype} hierarchies, and by their circular definitions. \ty{type} \doc{This type is the top of the {\it is-a} hierarchy. It is the type of types, so new types are created by instantiating it.} \ty{object} \doc{This type is the top of the {\it subtype}\ hierarchy, and has no supertype. Every other type is a subtype of \df{object}, so default methods for operations such as \df{print} are defined for \df{object}.} \section{Operations on Objects} The following operations are defined for all objects. Because they determine the semantics of the language, they cannot be redefined or shadowed. \op{get-type}{object} \doc{Returns the type of \df{object}.} \pr{eq?}{object object} \doc{Determines object identity. Two objects may look and act the same, but still fail the \df{eq?} test. In particular, numbers are not guaranteed to be unique. Symbols {\it are} interned, though.} \section{Operations on Types} Types are distinguished from other objects by the fact that they can perform the \df{make} operation, which is the mechanism for generating new objects. \op{make}{type} \doc{Returns a new instance of \df{type}.} The instance variables of an object returned by \df{make} are all bound to some unspecified value. Usually new objects need to be initialized in some other way, which can be accomplished by performing an operation on them immediately after they are made. By convention, this operation is \df{initialize}. \op{initialize}{object} \doc{Returns \df{object}.} This method for \df{initialize} is clearly a no-op. When a type requires special initialization, it should shadow this default. \section{Defining New Types} Since types are objects, new ones are created by sending a \df{make} message to the appropriate type object, which in this case is \df{type}. \makin{type}{ivars supertypes} \doc{Returns a new type-object with the supertypes and instance variables specified by the argument lists.} At run-time, methods are chosen by performing a left-to-right depth-first search on the supertype list.\footnote{Of course, Oaklisp implementations are free to use more efficient mechanisms that have the same effect.} Instances of the new type will contain a block of instance variables for each of the ancestor types, although duplicate types in the ancestor tree are eliminated.\footnote{This aspect of the language is in flux, and should not be relied upon by users.} \section{Type Predicates} The implicit type checking performed by the method invocation mechanism of Oaklisp reduces the need to call explicit type predicates. Furthermore, the two predicates defined in this section are sufficiently general to replace all of the ordinary Lisp type predicates such as \df{null?} and \df{number?}. A few of these have been retained to make the environment more familiar. \pr{is-a?}{object type} \doc{Determines whether \df{object} is an instance of \emph{type} or one of its subtypes. \texttt{(is-a? \emph{object} object)} is always true.} \pr{subtype?}{type1 type2} \doc{Determines whether \emph{type1} is a subtype of \emph{type2}. As you would expect, \df{subtype?} is transitive. Since each type is a subtype of itself, \df{subtype?} defines a partial ordering of all the types in the system.} \section{Constants} Some objects have external representations that are not self-evaluating expressions. \df{quote} allows the inclusion of such objects as constants in code. \sform{quote}{object} \doc{Returns \emph{object} without evaluating it.} \section{Standard Truth Values} \label{sec:truths} The standard truth values of Oaklisp are represented by the objects bound to the following variables. \gv{t} \doc{The value of this is \df{\#t}. Any non-false value will do just as well for the purpose of logical tests.} \gv{\#f} \doc{This is the false value, the only object recognized by logical tests as denoting falsehood.} \gv{nil} \doc{The value of this is the empty list, written \texttt{()}. Notice that \df{nil} itself is just a variable, so \texttt{(eq? nil 'nil)} is false.} \discuss{{\bf Note:} currently \texttt{()} is the same as \texttt{\#f}, the object used to represent falsehood. In the future it is possible that these two notions, emptiness and falsehood, will be disconfabulated. Programs should be written in such a way that if \df{\#f} and \df{()} were not the same object, they would still work.} \section{Coercion} Some types are \emph{coercable}, meaning that there is an operation associated with that type that allows objects to be coerced to that type. To create a coercable type, one instantiates \df{coercable-type} rather than \df{type}. \lo{coercer}{coercable-type} \doc{This returns the coercer of a type. For example, to coerce a list into a string one uses \dfcoer{string}, as in \evto{((coercer string) '(\#$\backslash$f \#$\backslash$o \#$\backslash$o))}{"foo"}. The reader will read \texttt{frog} preceded by a control-y character as \texttt{(coercer frog)}; this was motivated by the fact that control-y prints as $\rightarrow$ on both Macintosh$^{\mbox{tm}}$ and Symbolics computers, giving coercion a pleasant syntax, \evto{($\rightarrow$string '(\#$\backslash$f \#$\backslash$o \#$\backslash$o))}{"foo"}.} \ty{coercable-type} \doc{This is a subtype of \df{type} with has the added functionality of responding to the \df{coercer} message by returning its coercion operation. By default, \texttt{(is-a?\ \emph{foo} \emph{bar})} implies that \evto{((coercer \emph{bar}) \emph{foo})}{\emph{foo}}} \section{Mixing Types} Frequently, type hierarchies become so rich that they threaten to overwhelm users with a plethora of possible combinations of mixins. The combinatorial explosion of the number of possible concocted types seems intrinsic to the style of programming involving multiple functionally orthogonal mixins. Above a certain level of complexity, finding a type with certain known characteristics can become difficult. Programmers are left wondering ``Has a type based on \emph{foo} with \emph{bar, baz} and \emph{zonk} mixed in been created, if so what's its name, and if not what should I name it and where should I define it?'' Oaklisp's \emph{mixin managers} take care of this problem. When one needs ``the type based on \emph{foo} with \emph{bar, baz} and \emph{zonk} mixed in,'' one asks a mixin manager for it. If such a type has already been created, it is returned; if not, the mixin manager creates an appropriate new type, caches it, and returns it. This eliminates the burden of remembering which types have been concocted and what they are named. \op{mix-types}{mixin-manager type-list} \doc{This returns a composite type whose supertypes are \emph{type-list}. \emph{Mixin-manager} checks its cache, and if the requested type is not found it creates a type with \texttt{(make type '() \emph{type-list})}, caches it, and returns it.} \ty{mixin-manager} \doc{Instances of this cache composite types, acting as a sort of composite type library.} The Oaklisp operation type hierarchy is quite elaborite, containing a large number of functionally orthogonal mixins, and therefore the Oaklisp internals make heavy use of the mxin manager facility when dealing with operations. For example, the following definition for \df{+} is drawn from deep within the bowels of Oaklisp. \begin{verbatim} (define-constant-instance + (mix-types oc-mixer (list foldable-mixin open-coded-mixin operation))) \end{verbatim} oaklisp-1.3.3.orig/doc/lang/locales.tex0000664000175000000620000002313707725515164016735 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Evaluation and Locales} \label{locales} Locales are the namespace structuring mechanism of Oaklisp. Whenever an Oaklisp expression is evaluated, a locale must be provided in order to specify a particular mapping from symbols to macro-expanders and from symbols to storage cells. \section{Evaluation} \op{eval}{form locale} \doc{Evaluates \emph{form} relative to \emph{locale}.} Although programmers don't often need to call \df{eval} directly, every expression typed at the top level is passed in to \df{eval} to be evaluated relative to the locale specified by the fluid variable \df{current-locale}. Files may be evaluated using the \df{load} function. \op{load}{file-name $[$locale$]$} \doc{Reads all of the forms in the file \emph{file-name} and evaluates them relative to \emph{locale}, which defaults to the value of \dffl{current-locale} if not specified.} The file compiler can be used to create an assembly language file that has the same effect as an Oaklisp source file. \op{compile-file}{locale file-name} \doc{Compiles the file \emph{file-name} relative to \emph{locale}, which defaults to the value of \dffl{current-locale}. A file must be compiled and loaded relative to the same locale in order to guarantee that the program's semantics are preserved. Oaklisp source files have a default extension of \df{.oak} while compiled files are given the extension \df{.oa}. \df{compile-file} first tries to read the file \emph{file-name}\df{.oak}, and then looks for \emph{file-name}, while \df{load} looks first for \emph{file-name}\df{.oa}, then for \emph{file-name}\df{.oak}, and finally for \emph{file-name}.} \section{Installing Names in a Locale} Oaklisp has several forms that can be used to insert global variables and macro definitions into a locale. The target locale isn't explicitly specified by any of these forms, but is implicitly understood to be the locale with respect to which the form is being evaluated. Thus, when a form is typed at the top level, the effect is on \dffl{current-locale}, and when a file is loaded, the effect is on the locale specified in the call to \df{load}. \sform{define}{var val} \doc{Installs the global variable \emph{var} in the current locale with value \emph{val}.} \sform{define-constant}{var val} \doc{This form is like \df{define} except that \emph{var} is marked as frozen in the current locale so that the compiler can be free to substitute the value for references to \emph{var}.} \sform{define-instance}{var typ \dt make-args} \doc{If the contents of \emph{var} isn't of type \emph{typ}, this is the same as \texttt{(set! \emph{var} (make \emph{typ} . \emph{make-args}))}. If \emph{var} is already bound to an object of the right type, this form has no effect. \emph{Note:} this language feature is in flux. Currently, it sends an \df{initialize} message to the object with the new \emph{make-args}.} \sform{define-syntax}{macro-name expander} \doc{ Installs \emph{macro-name} in the current locale. \emph{expander} should be a lambda that is able to translate an example of the macro into a form that has simpler syntax. } As with all Oaklisp forms, the effect of a \df{define-syntax} form in a file is not felt until run-time when the file is loaded. Since it is often convenient to be able to use a macro in the file in which it is defined, a special mechanism has been provided for defining file-local macros that are in effect at compile time. The following magic forms should be used with care, since they violate the usually absolute dichotomy between compile time and load time. \sform{local-syntax}{macro-name expander} \doc{ During the compilation of a file in which a \df{local-syntax} form is contained, the form augments the name space with the macro specified by \emph{macro-name} and \emph{expander}. This form can only appear at top level in a file; and essentially disappears before load time. } \sform{define-local-syntax}{macro-name expander} \doc{ Temporarily augments the compile-time name space with the specified macro, and also installs the macro in the current locale when the file is loaded. This form can only appear at top level in a file. } \section{Structuring the Namespace} \discuss{ Oaklisp locales are not associated with textual binding contours, nor are they particularly user-friendly objects. They were designed to be a powerful implementation tool, leaving the task of providing a convenient interactive interface to higher-level code.} \op{make}{\df{locale} superior-list} \doc{Returns a new locale which inherits names from the locales in \emph{superior-list}. During recursive name lookups, the superiors are searched deapth first in left-to-right order.} \section{Variables} \label{variables} Locales are essentially mappings from symbols to storage cells. Although locales can be created on-the-fly, their main use is in building the structured top-level environment for global variables. Variable names must be installed in a locale before they can be referenced. Precise control over shadowing and cross-referencing can be achieved using the following settable operations. \so{variable?}{locale symbol} \doc{Returns a locative to the appropriate storage cell if \emph{symbol} is installed as a variable name, or \df{\#f} otherwise. The search is allowed to proceed to superior locales if necessary.} \setter{variable?}{locale symbol}{locative} \doc{If \emph{symbol} is not currently defined at any level, then it is installed in \emph{locale}, with the location named by \emph{locative} serving as its value cell. If \emph{symbol} is defined at some level, then its value cell at the highest level\footnote{\ie\ in the nearest locale to the one handling the operation.} is changed to be the location referenced by \emph{locative}.} \setter{variable?}{locale symbol}{\texttt{\#f}} \doc{If \emph{symbol} is defined at some level, then its definition is removed from the highest level. Otherwise an error is generated.} \so{variable-here?}{locale symbol} \doc{Returns a locative to the appropriate storage cell if \emph{symbol} is installed as a variable name, or \df{\#f} otherwise. The search is constrained to \emph{locale} itself.} \setter{variable-here?}{locale symbol}{locative} \doc{If \emph{symbol} is not currently defined in \emph{locale}, then it is installed, with the location named by \emph{locative} serving as its value cell. If \emph{symbol} is defined in \emph{locale}, then its value cell is changed to be the location referenced by \emph{locative}.} \setter{variable-here?}{locale symbol}{\texttt{\#f}} \doc{If \emph{symbol} is defined in \emph{locale} then its definition is removed. Otherwise an error is generated.} \section{Macros} Macro definitions are also stored in locales. These definitions are stored as a mapping from names to macro expanders. A macro expander is simply a one-argument function that takes an S-expression as its input and returns a transformed S-expression. Macro definitions are installed with the following settable operations, which are entirely analogous to the ones described in section \ref{variables}. \so{macro?}{locale symbol} \doc{Returns the appropriate macro expander if \emph{symbol} is installed as a macro name and \df{\#f} otherwise. The search is allowed to proceed to superior locales if necessary.} \so{macro-here?}{locale symbol} \doc{Returns the appropriate macro expander if \emph{symbol} is installed as a macro name, or \df{\#f} otherwise. The search is constrained to \emph{locale} itself.} \section{Compilation} All evaluation in Oaklisp is performed with respect to some locale. The syntax of the language is determined by the macro tables visible from that locale, and free variable references are likewise resolved using the global variables defined in its name space. %% % Evaluation is % performed by sending a \df{compile} message to the desired locale. % % \begin{group} % \op{(COMPILE locale form)} % \doc{Evaluates \df{form} in the name space defined by \df{locale} and % its ancestors.} % \end{group} % % \begin{group} % \op{(LOAD file locale)} % \doc{Completes the suspended evaluation of the form that was compiled to % \df{file}.\ \df{locale} must be the locale within which the % form was originally compiled.} % \end{group} % % \discuss{For improved efficiency, it is desirable for the compiler to % be able to open-code some functions. This is only possible if % the variables bound to those functions will never change their % values. The following operations may be used to inform the compiler that a % variable will always have the same value.} % % \spred{frozen?}{locale symbol} \doc{Returns \df{\#t} if \emph{symbol} is a frozen variable, otherwise \df{\#f}. The search is allowed to proceed to superior locales if necessary. If \emph{symbol} is not found anywhere, an error occurs.} \spred{frozen-here?}{locale symbol} \doc{Returns \df{\#t} if \emph{symbol} is a frozen variable, otherwise \df{\#f}. The search is constrained to \emph{locale} itself. If \emph{symbol} is not installed as a variable in \emph{locale}, an error occurs.} oaklisp-1.3.3.orig/doc/lang/io.tex0000664000175000000620000002717407725515164015727 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Input and Output} \section{Streams and Files} Streams are the tokens through which interaction with the outside world occurs. Although streams are primarily used for reading and writing to files, they have found a number of internal uses. \ty{stream} \doc{The supertype of all streams.} \ty{input-stream} \doc{This is an abstract type. Instantiable subtypes must define methods for the \df{really-read-char} operation.} \op{read-char}{input-stream} \doc{Return a character, or \df{the-eof-token} if we've already read the last character in the stream.} \op{unread-char}{input-stream character} \doc{Puts \emph{character} back into \emph{input-stream}. One can only put one character back, and it must be the last character read.} \op{peek-char}{input-stream} \doc{Equivalent to \texttt{(let ((c (read-char \emph{input-stream}))) (unread-char \emph{input-stream} c) c)}.} \ob{the-eof-token} \doc{This distinguished object is returned to indicate that one has read past the end of the file.} \ty{output-stream} \doc{This is an abstract type. Instantiable subtypes must define methods for the \df{write-char} operation.} \op{write-char}{output-stream character} \op{newline}{output-stream} \doc{Outputs a carriage return to \emph{output-stream}.} \op{freshline}{output-stream} \doc{Ensures that \emph{output-stream} is at the beginning of a line.} \op{flush}{output-stream} \doc{Flushes any buffered output.} \op{interactive?}{stream} \doc{Returns true if and only if \emph{stream} is connected to the user. This is used to check if an end of file condition on the control stream is really an end of file or if the user just typed control-D.} \so{position}{stream} \doc{Returns the position we are at within \emph{stream}. By setting this, one can get back to a previous position.} \op{write-string}{string output-stream} \doc{Writes the characters of \emph{string} to \emph{stream}.} \mc{with-open-file}{\lpar variable filename \dt options\rpar \dt body} \doc{Binds \emph{variable} to a stream which is connected to the file with the name \emph{filename}. \emph{Options} is not evaluated, and describes how \emph{filename} should be opened. Possible symbols include \df{in} for input, \df{out} for output, and \df{append} for output with position set to the end of the file. The \df{ugly} option can be added to either \df{out} or \df{append} if the user doesn't mind poor formating, as in files meant to be read only by other programs. The opened stream will be closed when the \df{with-open-file} is exited, even upon abnormal exit. {\bf Note:} the stream is not reopened upon abnormal entry, but this may be changed in future versions of the system.} \mc{with-input-from-string}{\lpar variable sequence\rpar \dt body} \doc{Binds \emph{variable} to an input stream whose contents are the characters of \emph{sequence}. Although \emph{sequence} is usually a string, this will work correctly for any sequence type.} \makin{string-output-stream}{} \doc{These save all their output and return it as a string in response to the \dfcoer{string} operation.} \section{Reading} Oaklisp has an industrial strength reader, replete with nonterminating macro characters and descriptive error messages. List syntax is not described below; read some other lisp manual. Our reader is modeled after the Common Lisp reader, so we emphasize differences with the Common Lisp reader below. \op{read}{input-stream} \doc{Returns a lisp object read from \emph{stream}. This is sensitive to a large number of factors detailed below.} \ob{standard-read-table} \doc{This holds the read table for usual lisp syntax. The \df{nth} operation can be used to get and set elements of read tables, which are indexed by characters. Potential entries are \df{whitespace}, \df{constituent}, \df{single-escape}, \df{illegal}, \emph{\lpar\df{terminating-macro} \dt operation\rpar}, and \emph{\lpar\df{nonterminating-macro} \dt operation\rpar}.} \op{skip-whitespace}{input-stream} \doc{Reads characters from \emph{input-stream} until the next character is not whitespace.} The reader is not sensitive to the case of macro characters. \op{define-macro-char}{character operation} \doc{Defines \emph{character} to be a reader macro in \df{standard-read-table}. When \emph{character} is encountered by the reader, \emph{operation} is called with two arguments, the stream and the character that was read.} \op{define-nonterminating-macro-char}{character operation} \doc{Just like \df{define-macro-char} except that the macro is not triggered if \emph{character} is read inside a token.} There are a number of ``quotelike'' macro characters present for the convenience of the user. \begin{center} \begin{tabular}{cl} \emph{macro character} & \emph{symbol} \\\hline \texttt{'} & \df{quote} \\ \texttt{`} & \df{quasiquote} \\ \texttt{control-v} & \df{fluid} \\ \texttt{control-y} & \df{coercer} \\ \texttt{,@} & \df{unquote-splicing} \\ \texttt{,} & \df{unquote} \end{tabular} \end{center} \op{define-quotelike-macro-char}{character object} \begin{docenv} Makes \emph{character} a terminating macro which returns a list of \emph{object} and the next thing read. This also arranges for the printer to print using analogous syntax. For instance, the quote syntax is defined with the line \texttt{(define-quotelike-macro-char \texttt{\#'} 'quote)} in the system internals. \end{docenv} \ob{the-unread-object} \doc{When a reader macro returns this, the reader takes it to mean that nothing at all was read. For instance, the reader macro for \texttt{;} reads the remainder of the line and returns this.} The character \texttt{[} is used to read lists in the same way that \texttt{(} is, except that \texttt{[} must be matched by a \texttt{]}. This is mostly for compatiblity with code written at the University of Indiana. Since there are no packages in Oaklisp, the \texttt{:} character is treated like any other constituent. Most of the Common Lisp hash reader macros are supported. For instance, the character object representing \texttt{a} is read \texttt{\#$\backslash$a}. Many special characters have long names, such as \texttt{\#$\backslash$space}. \op{define-hash-macro-char}{character operation} \doc{Defines \emph{character} to be a hash reader macro character. \emph{Operation} should take three arguments: a stream, the character, and the numeric argument that was between the hash and the character, \df{\#f} if none was passed.} There are many hash reader macro characters, including \df{\#o}, \df{\#x}, \df{\#d}, \df{\#b} and \df{\#c} for octal, hexidecimal, decimal, binary and complex numbers, respectively. The syntax \texttt{\#\emph{n}r\emph{xxx}} is used to read \emph{xxx} in base \emph{n}. \texttt{\#(\ldots)} is used for reading vectors. The \texttt{\#|} macro comments out text until a matching \texttt{|\#}, with proper nesting. As described in section \ref{sec:truths}, \df{\#t} and \df{\#f} are read as the canonical true and false values, respectively. The \texttt{\#[symbol "\ldots"]} syntax can be used to read arbitrary characters, although the \texttt{|$\ldots$|} construction is prefered. Analogous constructors can be added with the settable operation \df{hash-bracket-option}. \fv{input-base} \doc{The radix in which numbers will be read.} \fv{features} \doc{A list of ``features'' present in the current implementation, used by the \df{\#+} and \df{\#-} reader macros. Testable and settable with the \df{feature?} settable operation. It is guaranteed that the \df{oaklisp} and \df{scheme} features will be present in any implementation of Oaklisp.} \fv{current-locale} \doc{The \df{\#.} macro evaluates its argument in this locale.} \fv{read-suppress} \doc{This is true when what is being read will just be ignored, and indicates to the reader that it shouldn't go to the trouble of interpreting the meaning of complex tokens or anything like that.} \section{Printing} The printer is pretty heavy duty, but has no facilities for printing circular objects. \op{format}{stream control-string \dt args} \doc{This is very similar to the Common Lisp \df{format} function, and is the usual way for users to print things. \emph{Stream} is permitted to be \df{\#t} to indicate that output should be sent to the standard output, and \df{\#f} to indicate that the output should be bundled up into a string and returned. Characters in {control-string} are printed directly, except for the \texttt{\~} character which indicates that some action should be taken. The \texttt{\~} may be followed by a number or by a \texttt{:} or \texttt{@}, which vary the action that would normally be taken in some way. Currently defined \texttt{\~} characters and their associated actions are: \begin{itemize} \item[\texttt{A}] Print and argument with \dffl{print-escape} bound to \df{\#f}. \item[\texttt{\~}] Print a \texttt{\~}. \item[\texttt{\%}] Do a \df{newline}. \item[\texttt{\&}] Do a \df{freshline}. \item[\texttt{S}] Print an argument with \dffl{print-escape} bount to \df{\#t}. \item[\texttt{B}] Print an argument in binary. \item[\texttt{D}] Print an argument in decimal. \item[\texttt{O}] Print an argument in octal. \item[\texttt{X}] Print an argument in hex. \item[\texttt{\emph{n}R}] Print an argument in base \emph{n}. \item[\texttt{C}] Print an argument which is a character. \item[\texttt{P}] Print an \texttt{s} if the argument is not 1. \item[\texttt{!}] Print a weak pointer to the argument, preceded by an expression which evaluates to the argument if \dffl{fancy-references} is on. This is used to print unique id's for objects without nice printed representations, like operations. \end{itemize} A tilde followed by a newline is ignored; this construct is used for making \emph{control-string} more readable by breaking it across lines.} \op{print}{object stream} \doc{Writes a representation of \emph{object} to \emph{stream}. Users are encouraged to add informative print methods for types they define.} \op{define-simple-print-method}{type string} \doc{Instructs the printer to include \emph{string} in the printed representation of instances of \emph{type}.} \fv{print-radix} \doc{The radix in which numbers will be printed. The default is ten.} \fv{print-level} \doc{The number of levels of list structure to be printed before the printer abbreviates. The default is \df{\#f}, meaning never abbreviate.} \fv{print-length} \doc{The number of elements of a list to be printed before the printer abbreviates. The default is \df{\#f}, meaning never abbreviate.} \fv{print-escape} \doc{This controls whether the printer tries to print things that are easy for people to read, or ones that can be read back in to Oaklisp. The default is \df{\#t}, meaning to maintain print/read consistency at the expense of readability.} \fv{symbol-slashification-style} \doc{This controls the style of printing of symbols when they are escaped. See the implementation manual for details.} \fv{fraction-display-style} \doc{This can be either \df{normal}, \df{fancy} or \df{float}. In these cases, \texttt{(/ -5 3)} would print as either \texttt{-5/3}, \texttt{-1$\cdot$2/3} or \texttt{-1.6666666666}, respectively.} oaklisp-1.3.3.orig/doc/lang/Makefile0000664000175000000620000000225507725515164016227 0ustar barakstaff# This file is part of Oaklisp. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html # or from the Free Software Foundation, 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA all: lang.dvi SRC = control.tex cover.tex dynamic.tex intro.tex io.tex lang.tex \ locales.tex methods.tex misc.tex numbers.tex sequences.tex \ sides.tex types.tex user.tex OSRC = seqhier.ips numhier.ips lang.dvi: $(SRC) $(OSRC) ../mandefs.tex -rm lang.ind -latex lang all: lang.pdf SRC = control.tex cover.tex dynamic.tex intro.tex io.tex lang.tex \ locales.tex methods.tex misc.tex numbers.tex sequences.tex \ sides.tex types.tex user.tex OSRC = seqhier.ips numhier.ips lang.pdf : lang.dvi dvipdfm lang lang.dvi: $(SRC) $(OSRC) ../mandefs.tex -del lang.ind -latex lang }{n1 n2} \op{<=}{n1 n2} \op{>=}{n1 n2} \section{Predicates} \pr{zero?}{n} \pr{negative?}{n} \pr{positive?}{n} \pr{even?}{n} \pr{odd?}{n} \pr{factor?}{n1 n2} \section{Rounding} These operations should work on any subtype of \df{real}. \op{floor}{x} \doc{Returns the largest integer less than or equal to \emph{x}.} \op{ceiling}{x} \doc{Returns the smallest integer greater than or equal to \emph{x}.} \op{truncate}{x} \doc{Could be defined \texttt{(if (negative? x) (ceiling x) (floor x))}.} \op{round}{x} \doc{Returns nearest integer to \emph{x}. Ties are broken by rounding to an even number.} \section{Bitwise Logical Operations} These operations are only defined for integers. \op{ash-left}{i amount} \op{ash-right}{i amount} \op{rot-left}{i amount} \op{rot-right}{i amount} \op{bit-not}{i} \op{bit-and}{i1 i2} \op{bit-or}{i1 i2} \op{bit-nor}{i1 i2} \op{bit-xor}{i1 i2} \op{bit-nand}{i1 i2} \op{bit-andca}{i1 i2} \op{bit-equiv}{i1 i2} \section{Accessing Components} \op{numerator}{rational} \op{denominator}{rational} \op{real-part}{number} \op{imag-part}{number} oaklisp-1.3.3.orig/doc/lang/lang.tex0000664000175000000620000000315310752406631016220 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \documentclass[12pt]{report} % Blake McBride suggests [...,twoside]{book} \usepackage{times} \usepackage{fullpage} \usepackage{graphicx} \usepackage{makeidx} \usepackage[numbers]{natbib} \usepackage[hyphens]{url} \urlstyle{same} \makeindex \begin{document} \input{../mandefs} \include{cover} \tableofcontents \newpage \pagenumbering{arabic} \include{intro} \include{types} \include{methods} \include{sides} \include{locales} \include{dynamic} \include{control} \include{sequences} \include{numbers} \include{io} \include{misc} \include{user} \nocite{OAKLANG88} \nocite{CLOOPS} \nocite{FLAVORS2} \nocite{MVC} \nocite{R3RS} \nocite{SCHEME-DECLARATIVE} \nocite{SCHEME-PAP} \nocite{SNYDER86} \nocite{T} \nocite{T-MAN} \nocite{OAK-PAP} \nocite{3LISP} \nocite{FLAVORS1} \nocite{CLtL} \nocite{MULTILISP85} \nocite{ACTORS78} \nocite{CITY-TRASH} \nocite{PEARLMUTTER-LANG90A} \nocite{PEARLMUTTER99} \bibliography{../oakman} \printindex \end{document} oaklisp-1.3.3.orig/doc/lang/sequences.tex0000664000175000000620000001311207735462623017300 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Sequences} \label{Sequences} Sequences are manipulated using the \df{nth} operation, which is settable (and locatable). The sequence heirarchy is shown in figure~\ref{fig:seqhier}. \index{\texttt{sequence}} \index{\texttt{vector-type}} \index{\texttt{simple-vector}} \index{\texttt{list-type}} \index{\texttt{string}} \index{\texttt{pair}} \index{\texttt{null-type}} \index{\texttt{cons-pair}} \index{\texttt{lazy-cons-pair}} \begin{figure}[h] \centering\includegraphics{seqhier} \caption{The sequence type hierarchy. Abstract types are in plain face and instantiable ones in bold.} \label{fig:seqhier} \end{figure} \section{Type Predicates} \pr{sequence?}{object} \pr{vector?}{object} \pr{string?}{object} \pr{list?}{object} \pr{pair?}{object} \pr{null?}{object} \pr{atom?}{object} \section{Sequence Operations} These operations work on all sequences. \op{length}{list} \lo{nth}{list n} \lo{last}{list} \lo{tail}{list n} \op{copy}{sequence} \op{append}{sequence1 sequence2} \doc{Returns a sequence of the type of \emph{sequence1}. One slight bug is that one may not pass \df{append} a first argument that's a list and a second that's not. This may be fixed in the future. All other combinations should work correctly.} \op{append\protect\bang}{sequence1 sequence2} \doc{Most sequences have immutable lengths, and hence are not appropriate arguments to \df{append\protect\bang}. The major exception is lists. The same bug is present here as in \df{append}.} \op{reverse}{sequence} \op{reverse\protect\bang}{sequence} Some mapping operations are also applicable to sequences, and are documented in section \ref{sec:controlmap}. \section{Vector Constructors} \op{vector}{\dt objects} \doc{Returns a \df{simple-vector} containings \emph{objects}.} \makin{simple-vector}{length} \coercer{simple-vector}{sequence} \section{List Constructors} \op{list}{\dt objects} \makin{list-type}{length fill-value} \coercer{list-type}{sequence} \op{cons}{object1 object2} \makin{lazy-cons-pair}{car-thunk cdr-thunk} \mc{lcons}{car-form cdr-form} \doc{\macdef{}{(make lazy-cons-pair (lambda () \emph{car-form}) (lambda () \emph{cdr-form}))}} \section{List Accessors} \lo{car}{pair} \lo{cdr}{pair} \lo{c$[$ad$]^{*}$r}{pair} \doc{Actually these are only provided for up to four \texttt{a}'s and \texttt{d}'s. If you think you need more, you should probably be defining accessor functions or using \df{nth} or perhaps \df{destructure}.} \lo{last-pair}{pair} \doc{Takes successive \df{cdr}'s of \emph{pair} until it finds a pair whose \df{cdr} is not a pair, which it returns. \evto{(last-pair '(a b c))}{(c)}. \evto{(last-pair '(a b c . d))}{(c . d)}.} \mc{destructure}{template structure \dt body} \doc{This is for destructuring lists, and is sort of the inverse of backquote. \emph{Template} is a possibly nested list of variables. These variables are bound to the corresponding values of \emph{structure} while \emph{body} is evaluated. For instance, \macdef{(destructure (a (b) . c) x (foo a b c))}{(let ((a (car x))(b (caadr x))(c (cddr x))) (foo a b c))}. It is guaranteed that \emph{structure} will be evaluated only once. We note that \df{destructure} typically generates more efficient code than the corresponding code one might typically write. If there is a position in \emph{template} that should be ignored, one can place a \df{\#t} there. For convenience and compatiblity with \df{destructure*}, positions in \emph{template} containing \df{()}, \df{\#f} and \texttt{(quote \emph{x})} are also ignored.} \mc{destructure*}{template structure \dt body} \doc{This is just like \df{destructure} except that an error is signaled if \emph{structure} doesn't precisely match \emph{template}. Positions containing \df{\#f} and \df{()} are required to match literally. Positions containing \texttt{(quote \emph{x})} are required to match \emph{x} literally, where \emph{x} is not evaluated. As with \df{destructure}, positions containing \df{\#t} are ignored. \df{destructure*} is particularly useful in macro expanders where it can do much of the syntax checking automatically.} \mc{destructure**}{structure \lpar{}template \dt body\rpar ... [\lpar{}\texttt{otherwise} \dt nomatch-body\rpar]} \doc{This is just like \df{destructure*} except that, when one template does not match, the next in line is considered. If none match than the OTHERWISE one does; if no otherwise clause is present, an error is signaled.} \section{Lists as Sets} \op{mem}{predicate object list} \doc{Returns the first tail of \emph{list} whose \df{car} equals \emph{object} according to \emph{predicate}.} \op{memq}{object list} \op{del}{predicate object list} \op{delq}{object list} \op{del\protect\bang}{predicate object list} \op{delq\protect\bang}{object list} \section{Lists as Associations} \op{ass}{predicate object list} \op{assq}{object list} \so{cdr-ass}{predicate object list} \so{cdr-assq}{object list} \section{Lists as Stacks} \mc{push}{location object} \mc{pop}{location} oaklisp-1.3.3.orig/doc/lang/intro.tex0000664000175000000620000002215707725515164016447 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Introduction} \emph{This is the introduction to the original Oaklisp proposal which we wrote in January 1985. Although the core language hasn't changed since then, some of the periperal ideas in the proposal have been modified or abandoned.} One of the most interesting language ideas to emerge from the 1970's was the object-oriented programming model. Although this model has been incorporated to some extent in a number of recent Lisps, these implementations have not had the generality and power that characterize a true object-based system like Smalltalk. The most significant trend in the contemporary Lisp world is the move toward lexical scoping, which was initiated by Steele and Sussman with their Scheme papers and continued most faithfully by the designers of T. The major goal of Oaklisp was to combine the ideas of Smalltalk and Scheme in a simple but expressive language that inherits their exemplary properties of modularity and consistency. Unlike T, which adds an object-based capability to Scheme by constructing objects out of closures, Oaklisp builds a lexically scoped Lisp system on top of a general message-passing system that allows for full inheritance of methods from multiple superclasses. The first design choice for Oaklisp was the extent to which we should push the object-based model. We agreed with the designers of ADA that the packaging of state and procedures into new types can be a significant modularity tool for users of the language. We also agreed with the designers of the Lisp Machine that single-user Lisp systems should be open, with no clear line between system and user code. Therefore, both to allow the system implementors to use powerful user-level tools and to allow users to easily manipulate the system, we decided that absolutely everything should be a full-fledged object in Oaklisp. There is no reason why user-defined types should be any different from the types used to build the system. Oaklisp stands in marked contrast to other object-oriented Lisp systems which have magic data types that are not part of the user-level type hierarchy.\footnote{For example, ZetaLisp flavors are not themselves instances of flavors.} Our current Oaklisp implementation takes this idea to such an extreme that there are no magic objects anywhere in the system, no matter how deep you go. This meant not only that the vast majority of the system could be written in Lisp, but that the construction of the debugger and garbage collector was greatly simplified. As a corollary to the previous decision, we decided that all computation should be performed by methods that are invoked after a search up the type hierarchy. Functions can be thought of as methods attached to the top of the hierarchy, since they are methods that can perform an operation on any type. This leads to the interesting result that after a function has been defined, a new method can be added to take over that operation for a special case. The power of the method-invocation model of computation is derived from the generality of the inheritance mechanism.\footnote{It is primarily the lack of inheritance that weakens the T object facility.} A simple type-tree would have provided Oaklisp with the ability to define shadowable system-wide defaults for \df{print} and so forth. However, we felt that the mixin concept of flavors was such a valuable tool for factoring object functionality that inheritance from multiple supertypes was essential. This idea of inheriting from several mixins, each of which knows how to do something and encapsulates its own state, led to the following inheritance rule: a new type inherits all of the methods of its supertypes, but methods for the new type cannot refer to instance variables from the supertypes (even though those variables do exist in the new composite object.) This does not cause problems, because when operations for the supertypes are passed to the object, the methods which handle them {\it can} reference the appropriate instance variables. Since the names of instance variables are never inherited, conflicts cannot occur between names in the various supertypes. This treatment of instance variable names was also motivated by our decision to follow Scheme and make Oaklisp lexically scoped. Oaklisp not only benefits from the conceptual correctness which results from being able to close methods at compile time, but takes full advantage of tail-recursion and the lack of search associated with variable references. Once again, we decided to carry a principle to its extreme, and say that {\it all} variable references must be resolved at compile time, which results in both a simpler compiler and faster execution of code. Although this decision sounds intolerable for users, it actually represents a shift of functionality from the compiler to the error-handling system and user-interface, both of which we decided to make unusually powerful in our Oaklisp implementation. Another principle which we borrowed from Scheme is anonymity. The lack of coupling between names and objects gives the system a degree of modularity and flexibility that would otherwise be difficult to achieve. For example, if a type is redefined, old instances of that type will still have pointers to the old type descriptor. Operations on both kinds of object will be handled by the correct methods, and when the last instance of the old type goes away, the old type descriptor will also be garbage collected. The portion of Oaklisp that has been described so far can be considered its kernel. The portion that follows can mostly be implemented as methods at the user level. It is interesting to note that the dynamic variables and mutable binding contours which are described below can be built on top of a bare lexical Lisp kernel. However, the Oaklisp kernel is not a usable system, since we intentionally stripped it down knowing that the lost facilities would be replaced at a higher level. The first addition is a mutable binding contour facility based the locale structures of T.\footnote{In place of locales we could have implemented a simple top-level binding environment.} Oaklisp locales are objects that accept messages which install and look up names. Locales can have multiple superiors which are recursively searched if a name can't be found. Unlike T locales, Oaklisp locales are not associated with textual binding contours that can interact with \df{let}'s and generate ambiguities. Moreover, a reference to an undefined name creates an error, which means that forward references to uninstalled names are impossible. The second addition is a dynamic scoping facility that knows how to deal with \df{catch} and \df{throw}. The new dynamic variables are entirely separate from the static variables, and are always textually distinguishible from static variables to avoid confusion. Dynamic variables use deep-binding in our implementation so that they will behave correctly when there is more than one process. The implementation of dynamic variables is an issue since we decided to follow the Lisp Machine and implement light-weight processes that share the same address space to expedite data sharing and fast context switching. Our final design decision was also influenced by the Lisp Machine. Error handling in Oaklisp is designed to take maximum advantage of the type inheritance mechanism that is built into the language. A complete hierarchy exists of all the types of system errors. When an error occurs, an instance of that error type is created, and a message is sent to the error object asking for a handler to take control. The default message causes the debugger to be invoked. However, each process has some dynamic state which can be modified with the \df{condition-bind} construct to cause a different handler to be invoked when a particular error occurs at a particular time. This mechanism brings the full power of the language to bear on the problem of resolving errors, and is the reason that we felt we could make the language itself so strict with respect to variable references. Since our implementation of Oaklisp runs on the Lisp Machine and the Macintosh, it was no problem to delegate authority for reporting and resolving unbound variable references to the user-interface, which uses menus and dialog boxes to determine the user's intentions. If the user sets a switch that indicates that he wants unbound names to be automatically installed in the innermost locale, then the interface merely creates an error-handler to perform that function, and the user is not bothered again. oaklisp-1.3.3.orig/doc/lang/seqhier.ips0000664000175000000620000002766707013612755016754 0ustar barakstaff%!PS-Adobe-2.0 EPSF-1.2 %%DocumentFonts: Times-Roman Times-Bold %%Pages: 1 %%BoundingBox: 11 591 270 719 %%EndComments 50 dict begin /arrowHeight 8 def /arrowWidth 4 def /none null def /numGraphicParameters 17 def /stringLimit 65535 def /Begin { save numGraphicParameters dict begin } def /End { end restore } def /SetB { dup type /nulltype eq { pop false /brushRightArrow idef false /brushLeftArrow idef true /brushNone idef } { /brushDashOffset idef /brushDashArray idef 0 ne /brushRightArrow idef 0 ne /brushLeftArrow idef /brushWidth idef false /brushNone idef } ifelse } def /SetCFg { /fgblue idef /fggreen idef /fgred idef } def /SetCBg { /bgblue idef /bggreen idef /bgred idef } def /SetF { /printSize idef /printFont idef } def /SetP { dup type /nulltype eq { pop true /patternNone idef } { /patternGrayLevel idef patternGrayLevel -1 eq { /patternString idef } if false /patternNone idef } ifelse } def /BSpl { 0 begin storexyn newpath n 1 gt { 0 0 0 0 0 0 1 1 true subspline n 2 gt { 0 0 0 0 1 1 2 2 false subspline 1 1 n 3 sub { /i exch def i 1 sub dup i dup i 1 add dup i 2 add dup false subspline } for n 3 sub dup n 2 sub dup n 1 sub dup 2 copy false subspline } if n 2 sub dup n 1 sub dup 2 copy 2 copy false subspline patternNone not brushLeftArrow not brushRightArrow not and and { ifill } if brushNone not { istroke } if 0 0 1 1 leftarrow n 2 sub dup n 1 sub dup rightarrow } if end } dup 0 4 dict put def /Circ { newpath 0 360 arc patternNone not { ifill } if brushNone not { istroke } if } def /CBSpl { 0 begin dup 2 gt { storexyn newpath n 1 sub dup 0 0 1 1 2 2 true subspline 1 1 n 3 sub { /i exch def i 1 sub dup i dup i 1 add dup i 2 add dup false subspline } for n 3 sub dup n 2 sub dup n 1 sub dup 0 0 false subspline n 2 sub dup n 1 sub dup 0 0 1 1 false subspline patternNone not { ifill } if brushNone not { istroke } if } { Poly } ifelse end } dup 0 4 dict put def /Elli { 0 begin newpath 4 2 roll translate scale 0 0 1 0 360 arc patternNone not { ifill } if brushNone not { istroke } if end } dup 0 1 dict put def /Line { 0 begin 2 storexyn newpath x 0 get y 0 get moveto x 1 get y 1 get lineto brushNone not { istroke } if 0 0 1 1 leftarrow 0 0 1 1 rightarrow end } dup 0 4 dict put def /MLine { 0 begin storexyn newpath n 1 gt { x 0 get y 0 get moveto 1 1 n 1 sub { /i exch def x i get y i get lineto } for patternNone not brushLeftArrow not brushRightArrow not and and { ifill } if brushNone not { istroke } if 0 0 1 1 leftarrow n 2 sub dup n 1 sub dup rightarrow } if end } dup 0 4 dict put def /Poly { 3 1 roll newpath moveto -1 add { lineto } repeat closepath patternNone not { ifill } if brushNone not { istroke } if } def /Rect { 0 begin /t exch def /r exch def /b exch def /l exch def newpath l b moveto l t lineto r t lineto r b lineto closepath patternNone not { ifill } if brushNone not { istroke } if end } dup 0 4 dict put def /Text { ishow } def /idef { dup where { pop pop pop } { exch def } ifelse } def /ifill { 0 begin gsave patternGrayLevel -1 ne { fgred bgred fgred sub patternGrayLevel mul add fggreen bggreen fggreen sub patternGrayLevel mul add fgblue bgblue fgblue sub patternGrayLevel mul add setrgbcolor eofill } { eoclip originalCTM setmatrix pathbbox /t exch def /r exch def /b exch def /l exch def /w r l sub ceiling cvi def /h t b sub ceiling cvi def /imageByteWidth w 8 div ceiling cvi def /imageHeight h def bgred bggreen bgblue setrgbcolor eofill fgred fggreen fgblue setrgbcolor w 0 gt h 0 gt and { l b translate w h scale w h true [w 0 0 h neg 0 h] { patternproc } imagemask } if } ifelse grestore end } dup 0 8 dict put def /istroke { gsave brushDashOffset -1 eq { [] 0 setdash 1 setgray } { brushDashArray brushDashOffset setdash fgred fggreen fgblue setrgbcolor } ifelse brushWidth setlinewidth originalCTM setmatrix stroke grestore } def /ishow { 0 begin gsave fgred fggreen fgblue setrgbcolor /fontDict printFont findfont printSize scalefont dup setfont def /descender fontDict begin 0 [FontBBox] 1 get FontMatrix end transform exch pop def /vertoffset 0 descender sub printSize sub printFont /Courier ne printFont /Courier-Bold ne and { 1 add } if def { 0 vertoffset moveto show /vertoffset vertoffset printSize sub def } forall grestore end } dup 0 3 dict put def /patternproc { 0 begin /patternByteLength patternString length def /patternHeight patternByteLength 8 mul sqrt cvi def /patternWidth patternHeight def /patternByteWidth patternWidth 8 idiv def /imageByteMaxLength imageByteWidth imageHeight mul stringLimit patternByteWidth sub min def /imageMaxHeight imageByteMaxLength imageByteWidth idiv patternHeight idiv patternHeight mul patternHeight max def /imageHeight imageHeight imageMaxHeight sub store /imageString imageByteWidth imageMaxHeight mul patternByteWidth add string def 0 1 imageMaxHeight 1 sub { /y exch def /patternRow y patternByteWidth mul patternByteLength mod def /patternRowString patternString patternRow patternByteWidth getinterval def /imageRow y imageByteWidth mul def 0 patternByteWidth imageByteWidth 1 sub { /x exch def imageString imageRow x add patternRowString putinterval } for } for imageString end } dup 0 12 dict put def /min { dup 3 2 roll dup 4 3 roll lt { exch } if pop } def /max { dup 3 2 roll dup 4 3 roll gt { exch } if pop } def /arrowhead { 0 begin transform originalCTM itransform /taily exch def /tailx exch def transform originalCTM itransform /tipy exch def /tipx exch def /dy tipy taily sub def /dx tipx tailx sub def /angle dx 0 ne dy 0 ne or { dy dx atan } { 90 } ifelse def gsave originalCTM setmatrix tipx tipy translate angle rotate newpath 0 0 moveto arrowHeight neg arrowWidth 2 div lineto arrowHeight neg arrowWidth 2 div neg lineto closepath patternNone not { originalCTM setmatrix /padtip arrowHeight 2 exp 0.25 arrowWidth 2 exp mul add sqrt brushWidth mul arrowWidth div def /padtail brushWidth 2 div def tipx tipy translate angle rotate padtip 0 translate arrowHeight padtip add padtail add arrowHeight div dup scale arrowheadpath ifill } if brushNone not { originalCTM setmatrix tipx tipy translate angle rotate arrowheadpath istroke } if grestore end } dup 0 9 dict put def /arrowheadpath { newpath 0 0 moveto arrowHeight neg arrowWidth 2 div lineto arrowHeight neg arrowWidth 2 div neg lineto closepath } def /leftarrow { 0 begin y exch get /taily exch def x exch get /tailx exch def y exch get /tipy exch def x exch get /tipx exch def brushLeftArrow { tipx tipy tailx taily arrowhead } if end } dup 0 4 dict put def /rightarrow { 0 begin y exch get /tipy exch def x exch get /tipx exch def y exch get /taily exch def x exch get /tailx exch def brushRightArrow { tipx tipy tailx taily arrowhead } if end } dup 0 4 dict put def /midpoint { 0 begin /y1 exch def /x1 exch def /y0 exch def /x0 exch def x0 x1 add 2 div y0 y1 add 2 div end } dup 0 4 dict put def /thirdpoint { 0 begin /y1 exch def /x1 exch def /y0 exch def /x0 exch def x0 2 mul x1 add 3 div y0 2 mul y1 add 3 div end } dup 0 4 dict put def /subspline { 0 begin /movetoNeeded exch def y exch get /y3 exch def x exch get /x3 exch def y exch get /y2 exch def x exch get /x2 exch def y exch get /y1 exch def x exch get /x1 exch def y exch get /y0 exch def x exch get /x0 exch def x1 y1 x2 y2 thirdpoint /p1y exch def /p1x exch def x2 y2 x1 y1 thirdpoint /p2y exch def /p2x exch def x1 y1 x0 y0 thirdpoint p1x p1y midpoint /p0y exch def /p0x exch def x2 y2 x3 y3 thirdpoint p2x p2y midpoint /p3y exch def /p3x exch def movetoNeeded { p0x p0y moveto } if p1x p1y p2x p2y p3x p3y curveto end } dup 0 17 dict put def /storexyn { /n exch def /y n array def /x n array def n 1 sub -1 0 { /i exch def y i 3 2 roll put x i 3 2 roll put } for } def %%EndProlog %I Idraw 7 Grid @K %%Page: 1 1 Begin %I b u %I cfg u %I cbg u %I f u %I p u %I t [ 0.8 0 0 0.8 0 0 ] concat /originalCTM matrix currentmatrix def Begin %I Line %I b 65535 1 1 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 1 -140.5 231 ] concat %I 297 648 279 621 Line End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 1.43734 0 0 1 -195.904 98 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -134.407 96 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -6.407 142 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -98.407 141 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -62.407 185.5 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -233.907 95.5 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 1.19409 0 0 1 -305.337 141.5 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.989551 0 0 1 -186.046 186 ] concat %I 324 657 45 9 Elli End Begin %I Elli %I b 65535 1 0 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 1 SetP %I t [ 0.901099 0 0 1 -109.407 230 ] concat %I 324 657 45 9 Elli End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-medium-r-*-140-* /Times-Roman 14 SetF %I t [ 1 0 0 1 155.049 892.5 ] concat %I [ (sequence) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-medium-r-*-140-* /Times-Roman 14 SetF %I t [ 1 0 0 1 99.0687 848.5 ] concat %I [ (vector-type) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-medium-r-*-140-* /Times-Roman 14 SetF %I t [ 1 0 0 1 204.549 848 ] concat %I [ (list-type) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-bold-r-*-140-* /Times-Bold 14 SetF %I t [ 1 0 0 1 36.0491 804 ] concat %I [ (simple-vector) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-bold-r-*-140-* /Times-Bold 14 SetF %I t [ 1 0 0 1 40.0491 758 ] concat %I [ (string) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-medium-r-*-140-* /Times-Roman 14 SetF %I t [ 1 0 0 1 182.549 803.5 ] concat %I [ (pair) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-bold-r-*-140-* /Times-Bold 14 SetF %I t [ 1 0 0 1 126.549 758.5 ] concat %I [ (cons-pair) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-bold-r-*-140-* /Times-Bold 14 SetF %I t [ 1 0 0 1 221.293 760.5 ] concat %I [ (lazy-cons-pair) ] Text End Begin %I Text %I cfg Black 0 0 0 SetCFg %I f *-times-medium-r-*-140-* /Times-Roman 14 SetF %I t [ 1 0 0 1 258.549 804.5 ] concat %I [ (null-type) ] Text End Begin %I Line %I b 65535 1 1 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 1 -181 186.5 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 1 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 1 -220 141 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 1 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 1 -121.5 141 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 0 1 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 -1 -30.5 1454.5 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 0 1 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 -1 -65.5 1410.5 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 1 0 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 1 -85.5 185.5 ] concat %I 297 648 279 621 Line End Begin %I Line %I b 65535 1 0 1 [] 0 SetB %I cfg Black 0 0 0 SetCFg %I cbg White 1 1 1 SetCBg %I p 0 SetP %I t [ 1 0 0 -1 -76.5 1499 ] concat %I 297 648 279 621 Line End End %I eop showpage %%Trailer end oaklisp-1.3.3.orig/doc/lang/cover.tex0000664000175000000620000000266011036404254016412 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \begin{titlepage} \begin{center} \vspace*{1in} \Huge The \\ Oaklisp Language Manual \\ \vspace{.5in} \large \today \\ \vspace{.25in} % \Huge DRAFT \\ \vspace{.5in} \Large Barak A. Pearlmutter \\ \large Hamilton Institute\\ National University of Ireland Maynooth\\ Co.\ Kildare\\ Ireland\\ \url{barak+oaklisp@cs.nuim.ie} \vspace{.5in} \Large Kevin J. Lang \\ \large Yahoo!\ Research \\ \url{langk@yahoo-inc.com} \vfill % \vspace{0.25in} % The information in this document is subject to change at any time. \end{center} \end{titlepage} \thispagestyle{empty} \vspace*{6in} \normalsize \noindent Copyright \copyright 1985, 1986, 1987, 1988, 1989, 1991. by Barak A. Pearlmutter and Kevin J. Lang. \newpage \pagenumbering{roman} oaklisp-1.3.3.orig/doc/lang/user.tex0000664000175000000620000001734411036404254016257 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{User Interface} \label{user} The Oaklisp user interface currently consists of a read-eval-print loop and a simple debugging facility. Errors land the user into a recursive evaluation loop in which special restart handlers are available. Our implementation includes mechanisms for inspecting objects and tracing function calls. \section{The Top Level Environment} All expressions must be evaluated with respect to a particular naming environment. The read-eval-print loop uses the locale specified by the fluid variable \df{current-locale}. The Oaklisp system boots up with this variable bound to \df{user-locale}. Other useful name spaces are \df{scheme-locale}, \df{system-locale}, and \df{compiler-locale}. Several fluid variables are used to keep a short history of the dialogue conducted by the top level evaluator. The most useful of these is \dffl{*}, which contains the value produced by the most recent user expression. The value of this variable is rolled back into \dffl{**} and then into \dffl{***} to provide access to the three most recent values. Similarly, there are three copies of \dffl{+} and \dffl{?} that provide access to recent expressions that were read in and to their form after macro expansion. The switch \dffl{fancy-references} controls the printing of anonymous objects. When this switch is turned off, an object usually prints out something like this: \texttt{\#}. This format indicates the type of the object, and provides a weak pointer that can be derefenced with \df{object-unhash} to get the object. When the \dffl{fancy-references} switch is turned on, the printer attempts to generate an expression that will evaluate to the object in the current locale. For example, the above operation might print out as \texttt{\#}. The default value for this switch is \df{\#f}, but it is briefly switched on by \df{describe}. Two more fluid variables that are frequently used at the top level are \dffl{print-length} and \dffl{print-level}, which are normally set to small integer values in order to abbreviate the printing of long lists, but which can be set to \df{\#f} in order to enable exhaustive printing. %% % % The read-eval-print loop uses the \df{eval} function to perform the % actual evaluation of expressions. The \df{eval} function in turn % calls one of several functionally equivalent evaluation functions in % our implementation: \df{interpreter-eval}, \df{compiler-eval}, and % \df{hybrid-eval}. The variable \dffl{top-level-evaluator} % specifies which one should be used. \df{hybrid-eval} is the default % value in worlds that contain the compiler. This evaluator minimizes % top level latency by only using the compiler for expressions that % contain \df{add-method} forms. % % \section{Miscellaneous Functions} There are some other very useful functions that are part of the user interface. \op{apropos}{word [place]} \doc{Returns either variables or symbols containing \emph{word}, depending on \emph{place}, which can be a locale or \df{symbol-table}. \emph{place} defaults to \dffl{current-locale}.} \oop{\%gc} \doc{Collect garbage. This does not collect garbage in ``static space,'' but it is exceedingly unlikely that there is any there.} \oop{\%full-gc} \doc{Collect more garbage. This does collect garbage from ``static space,'' but more importantly, it put everything not freed into static space, so it need not be transported in future normal garbage collections.} \section{Debugging} The following special forms can be used to trace the execution of an operation. \sform{trace-variable-in}{global-var} \doc{Puts a trace on the operation stored in \emph{global-var}, causing a message to be printed every time the operation is called.} \sform{trace-variable-out}{global-var} \doc{Puts a trace on the operation stored in \emph{global-var}, causing a message to be printed every time a call to the operation returns.} \sform{trace-variable-in-out}{global-var} \sform{untrace-variable}{global-var} Objects can be examined in detail with the \df{describe} function, which prints the object and its type with \dffl{fancy-references} turned on, followed by the object's internal state. The internal state is organized as instance-variable blocks from the object's various component types. An object's internal state usually contains anonymous objects whose printed representation includes weak pointers which can be dereferenced using \df{object-unhash}. Together, \df{describe} and \df{object-unhash} constitute a simple but effective inspector. To simplify this process \texttt{describe} applied to an integer which is the \texttt{object-hash} of some object will describe that object. In other words, \texttt{describe} can be applied to the numeric ID in an object's printed representation. \op{describe}{object} \doc{Prints out lots of stuff about \emph{object}.} \op{object-unhash}{i} \doc{Dereferences the weak pointer \emph{i}.} When an error occurs in our implementation of Oaklisp, the user is thrown into a recursive evaluation loop whose dynamic context is nested inside that of the error. Several restart handlers are typically available in a recursive evaluation loop, and the \df{ret} function is the mechanism for invoking one of these handlers. \df{call/cc} can be used to preserve an error context when it might be useful to restart the computation at a later time. \op{ret}{n \dt args} \doc{Invokes restart handler \emph{n}, as specified by the list of handlers printed out by a subordinate evaluation loop. \texttt{(ret 0)}, which returns control to the top level evaluation loop, is always in effect.} The following dialogue with Oaklisp illustrates some of these points. \begin{verbatim} Oaklisp 1.0 - (C) 1987 Barak A. Pearlmutter and Kevin J. Lang. Oaklisp evaluation loop. Active handlers: 0: Return to top level. > (with-open-file (inf "fone.nums" in) (car (read inf))) Error: Error opening "fone.nums" for reading. Oaklisp evaluation loop. Active handlers: 0: Return to top level. 1: Retry opening file (argument for different file name). 2: Return to debugger level 1. >> (call/cc identity) ;get error context. >> (set foo (fluid *)) ;stash it away. >> (ret 0) ;back to top level. Invoking handler Return to top level.. > (describe foo) ;inspect continuation. # is of type #. from #: LAMBDA? : # ;what's this thing? CACHE-TYPE : 0 CACHE-METHOD : 0 CACHE-TYPE-OFFSET : 0 > (describe (object-unhash 802)) # is of type #. from #: THE-CODE : # THE-ENVIRONMENT : # > (foo 0) ;re-enter error context. >> (ret 1 "phone.nums") ;resume computation Invoking handler Retry opening the file ... 268-7598 ;got that phone number! > (exit) Oaklisp stopped itself... \end{verbatim} Using the error system effectively is an important part of providing the user with a helpful interface. Details on the error system can be found in section \ref{errors}. oaklisp-1.3.3.orig/doc/Makefile0000664000175000000620000000175407725515164015311 0ustar barakstaff# This file is part of Oaklisp. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html # or from the Free Software Foundation, 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA # This value of prefix will usually be overridden prefix=/usr/local .PHONY: all clean all clean: $(MAKE) -C lang $@ $(MAKE) -C lim $@ d=$(DESTDIR)$(prefix)/share/doc/oaklisp .PHONY: install install: $(MAKE) -C lang lang.ps $(MAKE) -C lim lim.ps mkdir --parents $d cp -a lang/lang.ps lim/lim.ps $d/ oaklisp-1.3.3.orig/doc/examples/0002775000175000000620000000000011036654362015454 5ustar barakstaffoaklisp-1.3.3.orig/doc/examples/unit-testing.oak0000664000175000000620000003770410111142035020571 0ustar barakstaff;;; FILE "unit-testing.oak" ;;; IMPLEMENTS Unit Testing for Oaklisp ;;; AUTHOR Ken Dickey ;;; COPYRIGHT (c) 2004 by Kenneth A Dickey; All rights reserved. ;;; This is free software. Permission to use, copy, modify and ;;; distribute this software for non-profit purpose is granted without ;;; fee. It is provided "as is" without express or implied warranty. ;;; The author disclaims all warranties with regard to this software. ;;; In no event shall the author be liable for any damages. ;;;USAGE SYNOPSIS ;; Tests are first created and added to a global UNIT-TESTS "database". ;; Tests are arranged by UNIT-NAME (just a symbol naming a set of tests). ;; ;; SPECIAL FORMS: ;; ;; (CREATE-TEST-SUITE unit-tests test-suite-name setup-thunk teardown-thunk) ;; Creates a and associates it with test-suite-name. ;; The SETUP-THUNK is executed before the unit tests are run and ;; TEARDOWN-THUNK is executed afterward. ;; ;; (ADD-TEST unit-name expected-result form =? . message) ;; ;; (ADD-EQ-TEST unit-name expected-result form . message) ;; => (add-test unit-name expected-result form EQ? . message) ;; ;; (ADD-EQUAL-TEST unit-name expected-result form . message) ;; => (add-test unit-name expected-result form EQUAL? . message) ;; ;; (ENSURE-EXCEPTION-RAISED unit-name exception-type form . message) ;; -> test that the form signals a (subtype of) exception-type ;; ;; All forms are "thunkified" by being wrapped in zero argument lambdas. ;; Internal usage is: (=? expected (thunk)) ;; ;; ;; TESTING OPERATIONS: ;; ;; (RUN-ALL-TESTS unit-tests) => Run all suites of tests. ;; ;; (RUN-TESTS-FOR unit-tests 'whatever) => Run tests for unit named WHATEVER. ;; ;; (REMOVE-TESTS-FOR unit-tests 'whatever) => Remove tests for unit named WHATEVER. ;; ..handy before rereading a test defining file. ;; ;; If (VERBOSE? unit-tests) is false, only failures and exceptions are ;; reported, else successful tests are reported as well. ;; The default value is #f. Settable. ;; ;; If (BREAK-ON-ERROR? unit-tests) is true, errors and exceptions break ;; into the debugger, otherwise failures are just reported. ;; The default value is #f. Settable. ;; ;; Tests are typically written as separate files containing set-up & tear-down code. ;; @@QUESTION: Add optional set-up and tear-down forms to unit test suites? ;; ;; Note Also: ;; (RUN-TEST (make ) verbose-p break-on-error-p) ;; Run a single -- typically only used for debugging tests. ;; If no error, don't report unless VERBOSE-P ;; If error or exception, break into debugger if BREAK-ON-ERROR-P, else continue ;; ;; (make unit-name expected thunk =? . message) ;; Nota Bene: Currently all output goes to (current-output-port). ;; Rebind this port to redirect output elsewhere, ;;;====================================================================== ;;; @@FIXME: TABLE-WALK belongs in hash-table.oak ;;; Should define WALK for SEQUENCE as well... (define-instance table-walk operation) ;; proc takes 2 args: (lambda (key val) ...) (add-method (table-walk (generic-hash-table table count size) self proc) (dotimes (index size) (let ( (chain (nth table index)) ) (for-each (lambda (bucket) (proc (car bucket) (cdr bucket))) chain)))) (add-method (table-walk (eq-hash-table table count size) self proc) (dotimes (index size) (let ( (chain (nth table index)) ) (for-each (lambda (bucket) (proc (car bucket) (cdr bucket))) chain)))) ;;;====================================================================== ;;;A keeps track of number passed, ;;; failed (actual != expected), excepted (signalled exception) ;;; and reports on these statistics. (define-instance type '(num-passed num-failed num-excepted) (list object)) (define-instance zero-counters operation) (define-instance increment-failed operation) (define-instance increment-passed operation) (define-instance increment-excepted operation) (define-instance number-failed operation) (define-instance number-passed operation) (define-instance number-excepted operation) (define-instance display-results operation) (add-method (zero-counters ( num-passed num-failed num-excepted) self) (set! num-passed 0) (set! num-failed 0) (set! num-excepted 0) self) (add-method (initialize ( num-passed num-failed num-excepted) self) (zero-counters self)) (add-method (increment-failed ( num-failed) self) (set! num-failed (+ 1 num-failed))) (add-method (increment-passed ( num-passed) self) (set! num-passed (+ 1 num-passed))) (add-method (increment-excepted ( num-excepted) self) (set! num-excepted (+ 1 num-excepted))) (add-method (number-failed ( num-failed) self) num-failed) (add-method (number-passed ( num-passed) self) num-passed) (add-method (number-excepted ( num-excepted) self) num-excepted) (add-method (display-results ( num-passed num-failed num-excepted) self port) (format port "~%TOTAL PASSED: ~D" num-passed) (format port "~%TOTAL FAILED: ~D" num-failed) (format port "~%TOTAL EXCEPTIONS: ~D~%~%" num-excepted) ) ;;;====================================================================== ;;;A is an UNnamed container of unit tests, setup and ;;; teardown code. Tests are a reversed list of ;;; instances (see below). A instance maintains the (name X ;;; unit-test-suite) bindings. (define-instance run-test operation) (define-instance run-all-tests operation) (define-instance run-tests-for operation) (define-instance type '(test-list setup-thunk teardown-thunk) (list object)) (add-method (initialize ( test-list setup-thunk teardown-thunk) self setup teardown) (set! test-list '()) (set! setup-thunk setup) (set! teardown-thunk teardown) self) (define-instance add-unit-test operation) (add-method (add-unit-test ( test-list) self unit-test) (unless (is-a? unit-test ) (error "(ADD-UNIT-TEST ) not a : ~a" unit-test)) (set! test-list (cons unit-test test-list))) (define-instance remove-tests-for operation) (add-method (remove-tests-for ( test-list) self) (set! test-list '())) (add-method (run-all-tests ( test-list setup-thunk teardown-thunk) self test-name result-counter verbose-p break-on-error-p) (if (null? test-list) ((if break-on-error-p error warn) "~&HUH? No tests found for ~A" test-name) (block (setup-thunk) (format #t "~%===> Starting Tests for ~a" test-name) (for-each (lambda (test) (run-test test result-counter verbose-p break-on-error-p)) (reverse test-list)) (format #t "~&===> Completed Tests for ~a~%" test-name) (teardown-thunk)) ) ) ;;;====================================================================== ;;;A contains and runs named test suites (define-instance type '(verbose-p break-on-error-p) (list eq-hash-table)) ; really a symbol-table (add-method (initialize ( verbose-p break-on-error-p) self) (set! verbose-p #f) (set! break-on-error-p #f) (^super eq-hash-table initialize self)) ;; @@FIXME: This should not be required. Why not simply inherited? (add-method ((setter table-entry) () self key value) (^super eq-hash-table (setter table-entry) self key value)) (define-instance verbose? settable-operation) (define-instance break-on-error? settable-operation) (add-method (verbose? ( verbose-p) self) verbose-p) (add-method ((setter verbose?) ( verbose-p) self bool) (set! verbose-p bool)) (add-method (break-on-error? ( break-on-error-p) self) break-on-error-p) (add-method ((setter break-on-error?) ( break-on-error-p) self bool) (set! break-on-error-p bool)) (define-instance create-test-suite operation) (define default-setup-thunk (lambda () #f)) (define default-teardown-thunk default-setup-thunk) (add-method (create-test-suite () self test-suite-name setup teardown) (let ( (test-suite (make setup teardown)) ) (set! (table-entry self test-suite-name) test-suite) test-suite ) ) (add-method (add-unit-test () self unit-name test-case) (unless (is-a? test-case ) (error "(ADD-UNIT-TEST name ) requires a , got: ~a" test-case)) (cond ((present? self unit-name) => (lambda (probe) (add-unit-test (cdr probe) test-case))) (else (error "Unit ~a not found. Try (CREATE-TEST-SUITE UNIT-TESTS ~a setup-thunk teardown-thunk)" unit-name unit-name))) test-case ) (define-instance remove-tests-for operation) ;; @@FIXME: no way to remove table entries ?!? (add-method (remove-tests-for () self unit-name) (cond ((present? self unit-name) => (lambda (probe) (remove-tests-for (cdr probe)))) (else (error "Unit ~a not found. Try (CREATE-TEST-SUITE UNIT-TESTS ~a setup-thunk teardown-thunk)" unit-name unit-name))) ) remove ;;; UNIT-TESTS global (define-constant unit-tests (make )) ;;;====================================================================== ;;; A is a single test (define-instance type '(expected thunk compare? message) (list object)) (add-method (initialize ( expected thunk compare? message) self expected-result the-thunk comparison-op? msg) (set! expected expected-result) (set! thunk the-thunk) (set! compare? comparison-op?) (set! message msg) self) (define-syntax (add-test unit-name expect form equivalent? . message) (let ( (msg (if (pair? message) (car message) "")) ) `(add-unit-test unit-tests ,unit-name (make ,expect (lambda () ,form) ,equivalent? ,msg) ) ) ) (define-syntax (add-eq-test unit-name expect form . message) `(add-test ,unit-name ,expect ,form eq? . ,message)) (define-syntax (add-equal-test unit-name expect form . message) `(add-test ,unit-name ,expect ,form equal? . ,message)) (define-syntax (ensure-exception-raised unit-name exception-type form . message) (let ( (msg (if (pair? message) (car message) "")) ) `(add-unit-test unit-tests ,unit-name (make ,exception-type (lambda () ,form) ,msg) ) ) ) (define-instance type '() (list )) (add-method (initialize () self exception-type thunk message) (unless (subtype? exception-type condition) (error "An requires an exception type: ~a" exception-type)) (^super initialize self exception-type thunk subtype? message) self) (define (warn format-string . format-args) ;; like WARNING, but without the extra "Warning"" line (format standard-error format-string . format-args)) ;;;====================================================================== ;;; RUNNING TESTS ;; Run a ;; If no error, don't report unless VERBOSE-P ;; If error or exception, break into debugger if BREAK-ON-ERROR-P, else continue ;; Result-counter is-a (add-method (run-test ( expected thunk compare? message) self result-counter verbose-p break-on-error-p) (let* ( (caught-exception #f) (actual (bind-error-handler (general-error ;; catch every type of error (lambda (err-obj) (set! caught-exception err-obj) (format #t "~&*** EXCEPTION: ~a -- ~a" err-obj message) (when verbose-p (describe err-obj)) #f)) (thunk))) ) (cond (caught-exception => (lambda (err-obj) (increment-excepted result-counter) (if break-on-error-p (invoke-debugger err-obj) err-obj)) ;; return err-obj if not breaking ) ((compare? actual expected) (increment-passed result-counter) (if verbose-p (format #t "~&PASSED: Expected: ~a Got: ~a -- ~a" expected actual message) #t) ;; compare => #t ) (else (increment-failed result-counter) ((if break-on-error-p error warn) "~&*** FAILED: Expected ~a Got ~a -- ~a" expected actual message))) ) ) (add-method (run-tests-for ( verbose-p break-on-error-p) self unit-name) (let ( (probe (present? self unit-name)) (result-counter (make )) ) (if probe (block (run-all-tests (cdr probe) unit-name result-counter verbose-p break-on-error-p) (display-results result-counter #t)) ((if break-on-error-p error warn) "~&HUH? No tests found for ~A" unit-name))) ) (add-method (run-all-tests ( verbose-p break-on-error-p) self) (let ( (result-counter (make )) ) (table-walk self (lambda (unit-name test-suite) (if test-suite (run-all-tests test-suite unit-name result-counter verbose-p break-on-error-p) ((if break-on-error-p error warn) "~&HUH? No tests found for ~A" unit-name)))) (display-results result-counter #t) ) ) (define-instance %run-exception-test operation) ;; NB: Runs in (fluid current-locale) which is probably USER-LOCALE (add-method (run-test () self result-counter verbose-p break-on-error-p) ;; helper required for access to internals (%run-exception-test self result-counter verbose-p break-on-error-p)) (add-method (%run-exception-test ( expected thunk compare? message) self result-counter verbose-p break-on-error-p) (let* ( (caught-exception #f) (actual (bind-error-handler (general-error ;; catch every type of error (lambda (err-obj) (set! caught-exception err-obj) err-obj)) (thunk))) ) (cond ((compare? (get-type actual) expected) (increment-passed result-counter) (if verbose-p (format #t "~&PASSED: Expected: ~a Got: ~a of type ~a -- ~a" expected actual (get-type actual) message) #t) ;; compare => #t ) (caught-exception => (lambda (err-obj) (increment-excepted result-counter) (format #t "~&*** UNEXPECTED EXCEPTION: got ~a of type ~a expected ~a -- ~a" err-obj (get-type err-obj) expected message) (when verbose-p (describe err-obj)) (if break-on-error-p (invoke-debugger err-obj) err-obj)) ;; return err-obj if not breaking ) (else (increment-failed result-counter) ((if break-on-error-p error warn) "~&*** FAILED: Expected exception of type ~a Got value: ~a -- ~a" expected actual message))) ) ) ;;; unit-testing.oak ends here oaklisp-1.3.3.orig/doc/examples/change.oak0000664000175000000620000000500611036404254017365 0ustar barakstaff;;; This file is part of Oaklisp. ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; The GNU GPL is available at http://www.gnu.org/licenses/gpl.html ;;; or from the Free Software Foundation, 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA ;;; Number of ways of giving change, Barak A. Pearlmutter, Fall 1989. ;;; This technique is covered in Concrete Mathamatics by Graham, Knuth ;;; and Patashnik, page 331. ;;; Helper functions: ;;; This computes the number of ways to choose m objects from a pool ;;; of n. The arguments are in the usual mathematical order. (define (choose n m) (let aux ((n n)(m1 m)(total 1)) (if (= m1 0) (let aux ((m m)(total2 1)) (if (= m 0) (/ total total2) (aux (- m 1) (* m total2)))) (aux (- n 1) (- m1 1) (* n total))))) ;;; These are the coefficients of the polynomial a(z) = (1-z^{10})^5 / ;;; (1-z)^2(1-z^2)(1-z^5)(1-z^{10}). The end should be zero padded to ;;; infinity, but the arguments given are always between 0 and 39 ;;; inclusive. (define (a i) (nth '(01 02 04 06 09 13 18 24 31 39 45 52 57 63 67 69 69 67 63 57 52 45 39 31 24 18 13 09 06 04 02 01 0 0 0 0 0 0 0 0) i)) ;;; This returns the number of ways to make change on c cents using ;;; coins of denomination 1,5,10,25,50. The math behind this is too ;;; hairy for a comment, as it requires lots of superscripts and sums ;;; and stuff. In effect, we end up casing on (c mod 50) with each ;;; case determining the coefficients of a fourth order polynomial of ;;; floor(c/50). (define (change c) (let* ((c5 (quotient c 5)) (q (quotient c5 10)) (r (modulo c5 10))) (+ (* (a r) (choose (+ q 4) 4)) (* (a (+ r 10)) (choose (+ q 3) 4)) (* (a (+ r 20)) (choose (+ q 2) 4)) (* (a (+ r 30)) (choose (+ q 1) 4))))) ;;; Test case, the number of ways of giving change for $1,000,000.00 ;;; (change 100000000) = 66666793333412666685000001. ;;; For $1,000,000,000,000,000,000.00, ;;; (change 100000000000000000000) ;;; 66666666666666666793333333333333333412666666666666666685000000000000000001 ;;; eof oaklisp-1.3.3.orig/doc/examples/bank-example.oak0000664000175000000620000001457010111142115020476 0ustar barakstaff;; FILE "bank-example.oak" ;; IMPLEMNETS Bank account example from YASOS article ;; AUTHOR Ken Dickey ;; DATE 5 aUGUST 2004 ;; (define-predicate foo?) ;;-> (define-instance foo? operation) ;; (add-method (foo? (object) self) #f) (define-local-syntax (define-predicate name) `(block (define-instance ,name operation) (add-method (,name (object) self) #f))) ;; (add-predicate-true foo? type) ;;-> (add-method (foo? (type) self) #t) (define-local-syntax (add-predicate-true name type) `(add-method (,name (,type) self) #t)) ;; (define-type name slots supers) ;; -> (define-instance name TYPE slots (list super...)) (define-local-syntax (define-object-type name slots . supers) `(define-instance ,name type ',slots (list ,@supers))) (define-local-syntax (define-operation name) `(define-instance ,name operation)) (define-local-syntax (define-settable-operation name) `(define-instance ,name settable-operation)) ;; @@DEBUG ;; (define trace-expansion #t) ;; Test 'em out ;; (define-predicate person?) (define-object-type (name age SSN password) object) (add-predicate-true person? ) (add-method (initialize ( name age SSN password) self the-name the-age the-ssn the-password) (set! name the-name) (set! age the-age) (set! SSN the-ssn) (set! password the-password) self) (define-operation name) (define-settable-operation age) (define-operation SSN) (define-operation bad-password) (define-operation change-password) (add-method (name ( name) self) name) (add-method (age ( age) self) age) (add-method ((setter age) ( age) self new-age) (set! age new-age)) (add-method (SSN ( SSN password) self a-password) (if (equal? password a-password) SSN (bad-password self a-password))) (add-method (bad-password () self bogus-password) (let ( (message (format #f "bad password \"~a\"" bogus-password)) ) (format #t "~%~a" message) message)) (add-method (change-password ( password) self old-passwd new-passwd) (if (equal? old-passwd password) (block (set! password new-passwd) self) (bad-password self old-passwd))) ;; ;; Just a reverse list of balances (i.e. newest 1st, oldest last) (define-object-type (reverse-history) object) (add-method (initialize ( reverse-history) self initial-balance) (set! reverse-history (list initial-balance)) self) (define-instance history operation) (define-instance add operation) (add-method (history ( reverse-history) self) (reverse reverse-history)) (add-method (add ( reverse-history) self new-balance) (set! reverse-history (cons new-balance reverse-history)) new-balance) ;; (define-predicate bank-account?) (define-object-type (master-password p-i-n balance) ) (add-predicate-true bank-account? ) (add-method (initialize ( master-password p-i-n balance) self master-passwd initial-balance name age SSN PIN) (set! master-password master-passwd) (set! p-i-n PIN) (set! balance initial-balance) (^super initialize self initial-balance) (^super initialize self name age SSN p-i-n) self) (define-operation current-balance) ;;(define-operation add operation) @@@ defined above (define-operation withdraw) (define-settable-operation PIN) (add-method (current-balance ( balance p-i-n master-password) self passwd) (if (or (equal? passwd p-i-n) (equal? passwd master-password)) balance (bad-password self passwd))) (add-method (pin ( master-password p-i-n) self passwd) (if (equal? passwd master-password) p-i-n (bad-password self passwd))) (add-method ((setter pin) ( master-password p-i-n) self passwd new-pin) (if (equal? passwd master-password) (block (^super change-password self p-i-n new-pin) (set! p-i-n new-pin) self) (bad-password self passwd))) (add-method (change-password ( master-password p-i-n) self old-passwd new-passwd) (if (equal? old-passwd p-i-n) ((setter pin) self master-password new-passwd) (bad-password self old-passwd))) (add-method (bad-password () self bogus-pssword) (format #t "~%!!! CALL THE POLICE !!!") (error "!!! CALL THE POLICE !!!")) (add-method (history ( master-password p-i-n) self passwd) (if (or (equal? passwd p-i-n) (equal? passwd master-password)) (^super self history) (bad-password self passwd))) (add-method (add ( balance) self amount) ;; dumb checks elided (e.g. amount > 0) (set! balance (+ balance amount)) (^super add self balance) (format #t "~%new balance is ~a" balance) self) (add-method (withdraw ( balance p-i-n) self amount passwd) (cond ((not (equal? passwd p-i-n)) (bad-password self passwd)) ((> amount balance) (format #t "~%Error: can't withdraw more than you have!")) (else (set! balance (- balance amount)) (^super add self balance) (format #t "~%new balance is ~a" balance)))) (add-method (SSN () self passwd) (^super SSN self passwd)) ;; --- E O F --- ;; oaklisp-1.3.3.orig/doc/examples/test-bank-example.oak0000664000175000000620000000732210111142115021450 0ustar barakstaff;; FILE "test-bank-example.oak" ;; IMPLEMENTS Test code for "bank-example.oak" ;; AUTHOR Ken Dickey ;; DATE 5 August 2004 ;; (require 'init-testing) ;; (require 'bank-example) (define-constant test-name 'bank-example) (define-constant name-1 "Joe Tester") (define-constant SSN-1 "534-39-4834") (define-constant passwd-1 'joe-passwd) (define-constant age-1 23) (define-constant new-age-1 (+ 1 age-1)) (define-constant new-passwd-1 'new-joe-passwd) (define-constant new-passwd-2 'changed-joe-passwd) (define-constant bank-passwd 'secret-bank-password) (define-constant initial-balance 200) (define-constant (setup-thunk) (define person-1 (make name-1 age-1 SSN-1 passwd-1)) (define history-1 (make 37)) (define bank-account-1 (make bank-passwd initial-balance name-1 age-1 SSN-1 passwd-1)) ) (define-constant (teardown-thunk) #f ;; no action ) (setup-thunk) ;; define the records (create-test-suite unit-tests test-name setup-thunk teardown-thunk) (add-equal-test test-name name-1 (name person-1) "person name") (add-equal-test test-name SSN-1 (SSN person-1 passwd-1) "person SSN") (add-equal-test test-name age-1 (age person-1) "person age") (add-equal-test test-name new-age-1 (block (set! (age person-1) new-age-1) (age person-1)) "age setter") (add-equal-test test-name "bad password \"BOGUS\"" (SSN person-1 'bogus) "bad person password") (add-eq-test test-name new-passwd-1 (block (change-password person-1 passwd-1 new-passwd-1) new-passwd-1) "password update (always succeeds)") (add-equal-test test-name SSN-1 (SSN person-1 new-passwd-1) "SSN for password update") (add-eq-test test-name #t (person? person-1) "(person? )") (add-eq-test test-name #f (person? 3) "(person? 3)") (add-equal-test test-name '(37) (history history-1) "37") (add-equal-test test-name '(37 45) (block (add history-1 45) (history history-1)) "37 45") (add-equal-test test-name initial-balance (current-balance bank-account-1 passwd-1) "initial balance 1") (add-equal-test test-name initial-balance (current-balance bank-account-1 bank-passwd) "initial balance 2") (add-equal-test test-name SSN-1 (SSN bank-account-1 passwd-1) "bank SSN") (ensure-exception-raised test-name generic-fatal-error (SSN bank-account-1 'bogus) "bogus password") (add-equal-test test-name passwd-1 (PIN bank-account-1 bank-passwd) "PIN") (add-equal-test test-name 250 (block (add bank-account-1 50) (current-balance bank-account-1 bank-passwd)) "add to balance") (add-equal-test test-name 225 (block (withdraw bank-account-1 25 (pin bank-account-1 bank-passwd)) (current-balance bank-account-1 (PIN bank-account-1 bank-passwd))) "withdraw from balance") (add-eq-test test-name 'new-joe-pin (block ((setter PIN) bank-account-1 bank-passwd 'new-joe-pin) (PIN bank-account-1 bank-passwd)) "new PIN") (add-equal-test test-name new-passwd-2 (block (change-password bank-account-1 (PIN bank-account-1 bank-passwd) new-passwd-2) (PIN bank-account-1 bank-passwd)) "PIN after password change") ;; (run-all-tests unit-tests test-name) ;; --- E O F --- ;; oaklisp-1.3.3.orig/doc/lim/0002775000175000000620000000000011036654362014417 5ustar barakstaffoaklisp-1.3.3.orig/doc/lim/admin.tex0000664000175000000620000000564710752422364016242 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Administrative Details} \section{Getting a Copy} The most recent released version of Oaklisp, along with the manuals, are available at \url{http://www.bcl.hamilton.ie/~barak/oaklisp/}, but this is to be superseded by a new site: \url{http://oaklisp.alioth.debian.org/}. \section{Bugs} The following are known serious problems and inadequacies of the current implementation. People are invited to work on remedying them. None of these are fundamental; they're simply due to lack of either effort or motivation. \begin{itemize} \item Floating point numbers are not supported. Rationals can be used to make up for this lack. \item In contrast to the error handling system, which is Industrial Strength, the debugger barely exists. \item There is no foreign function interface for loading and calling C routines from a running Oaklisp. %% Removed because this has been tightened up so much that only someone %% familiar with the internals would be able to cobble up something that %% would cause a core dump when invoked, and that would take some work. % % \item Calling some non-operations dumps core rather than invoking the % debugger. \end{itemize} Bug reports, enhancements, and the like should be posted using the facilities on \url{http://oaklisp.alioth.debian.org/}; queries can also be sent to \texttt{barak+oaklisp@cs.nuim.ie}. We appreciate enhancements (especially in the form of patch files), bug fixes, and bug reports. We are particularly grateful for porting problem fixes. In a bug report, please include the precise version of Oaklisp, which is indicated by the date at the end of the tar file. And please try to make sure that it's really a bug and not a feature, and pretty please, if at all possible, find a \emph{very short} program that manifests your bug. In any case please be aware that we are under no obligation to respond to bug reports in any way whatsoever. \section{Copyright and Lack of Warranty} The Oaklisp copyright belongs to its authors. It is authorized for distribution under the GNU General Public License, version 2, copies of which are readily obtainable from the Free Software Foundation. There is no warranty; use at your own risk. For more precise information, see the COPYING file in the Oaklisp source distribution. oaklisp-1.3.3.orig/doc/lim/oaklevel.tex0000664000175000000620000005116011036617630016741 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Oaklisp Level Implementation} Once the core of the language is up, the rest of the language is implemented using the language core. Some of these new language constructs require some support from the bytecode emulator along with considerable Oaklisp level support. These include such features as \df{call/cc} and its simple cousin \df{catch}. Others are implemented entirely in the core language without the use of special purpose bytecodes; in this latter class fall things like infinite precision integers (so called \emph{bignums}), fluid variables, and the error system. In this chapter we describe the implementation of these constructs, albeit sketchily. For more details, the source code is publicly available. We do not describe the implementation of locales or other extremely high level features; read the source for the details, which are quite straightforward. \section{Fluid Variables} \label{fluid-impl} Our implementation of fluid variables uses deep binding. A shallow bound or hybrid technology would presumably speed fluid variable reference considerably, but they are used rarely enough that we have not bothered with such optimizations. In addition, shallow binding interacts poorly with multiprocessing. \gv{fluid-binding-list} \doc{Hold an association list which associates fluid variables to their values. The \df{bind} construct simply pushes variable/value pairs onto this list before executing its body and pops them off afterwards.} It would be easy to implement fluid variables using the unwind protection facilities, but instead the abnormal control constructs (\df{native-catch} and \df{call/cc}) are careful to save and restore \df{fluid-binding-list} properly. This avoids the overhead of using the wind facilities and makes sure that (ignoring \df{wind-protect}) \df{fluid-binding-list} is only manipulated once for every abnormal exit, no matter how many \df{bind} constructs are exited and entered along the way. \lo{\%fluid}{symbol} \doc{This looks \emph{symbol} up on \df{fluid-binding-list}. If it is not found an error is signaled. In contrast, \texttt{(setter \%fluid)} silently adds new fluid variables to the end of the association list, thus creating new top level fluid bindings.} \section{Unwind Protection} \label{sec:oakwind} In the presence of \df{call/cc}, a simple \df{unwind-protect} construct a.\ la.\ Common Lisp does not suffice. Because control can enter a dynamic context which has previously been exited, symmetry requires that if we have forms that get executed automatically when a context is abnormally exited, we must also have ones that get executed automatically when a context is abnormally entered. For this purpose the system maintains some global variables that reflect the state of the current dynamic context with respect to these automatic actions. \gv{\%windings} \doc{This is a list of wind/unwind action pairs, one of which is pushed on each time we enter a \df{dynamic-wind} and poped off when we leave it. The wind/unwind action pairs are of the form \texttt{(\emph{after} \emph{before} . \emph{saved-fluid-binding-list})} where \emph{before} and \emph{after} are operations, guards to be called when leaving and entering this dynamic context respectively, and \emph{saved-fluid-binding-list} is the appropriate value for \df{fluid-binding-list} when calling these guard operations.} \gv{\%wind-count} \doc{To reduce \df{find-join-point}'s complexity from quadratic to linear, we maintain \df{\%wind-count} $=$ \texttt{(length \%windings)}.} \section{Catch} \label{sec:oakcatch} The format of catch tags is describe in section \ref{sec:ctagform}. The simplest implementation of \df{native-catch} would have the \df{native-catch} macro expand into something that executed the appropriate unwind protect actions and restored the fluid binding list before resuming execution. Regretably, the unwind protect actions can themselves potentially \df{throw}, so the stacks must not be chopped off until after the unwind protect actions have been completed. For this reason the \df{throw} operation doesn't just call the \df{throw} instruction, but first performs all the appropriate unwind protect actions. Along with stack heights, the catch tag contains \df{saved-wind-count}, which is used to compute how many elements of \df{\%windings} must be popped off and called, and \df{saved-fluid-binding-list}, which is restored immediately before the stacks are actually chopped off. \section{Call/CC} The \df{call/cc} construct is just like \df{native-catch}, except that the saved stack state isn't just some offsets but is an entire stack photo (see section \ref{sec:stackimpl}), and that not only unwinding but also rewinding actions might need to be done. Because the winding actions might \df{throw}, it is necessary for the unwind actions to be executed in the stack context where the continuation is invoked, and similarly the rewind actions must be executed in the destination stack context. \gv{\%\%join-count} \gv{\%\%new-windings} \gv{\%\%new-wind-count} \gv{\%\%cleanup-needed} \doc{These global are used to pass information about which rewind actions need to be executed by the destination of the continuation, since the normal parameter passing mechanisms are not available. This would have to be done on a per processor basis in a multithreaded implementation.} Continuations contain \df{saved-windings} and \df{saved-wind-count} instance variables, which have the values of \df{\%windings} and \df{\%wind-count} at the time the \df{\%call/cc} was entered. Before the continuation is actually invoked and the destination stack photos restored, the highest join point between current and the destination winding lists is found, and all the unwind actions needed to get down to the join point are executed. Then the stack photo is restored, and in the destination context the rewinding actions are done to get up from the join point to the destination point. \section{The Error System} The error system is pretty complete, but is actually not only easy to use, but also intuitive and fun, particularly at the user level. \mc{error-return}{message \dt body} \doc{Evaluates \emph{body} in a dynamic context in which a restart handler is available that can force the form to return. The handler is identified by \emph{string} in the list of choices printed out by the debugger. If the handler is invoked by calling \df{ret} with an argument in addition to the handler number, the \df{error-return} form returns this additional value; otherwise it returns \df{\#f}. If no error occurs, an \df{error-return} form yields the value of \emph{body}.} \mc{error-restart}{message let-clauses \dt body} \doc{Acts like a \df{let}, binding the \emph{let-clauses} as you would expect, except that if an error occurs while evaluating \emph{body}, the user is given the option of specifying new values for the variables of the \emph{let-clauses} and starting \emph{body} again. This is implemented with a \df{native-catch} and some tricky restart handlers that get pushed onto \texttt{(fluid restart-handlers)}.} \fv{restart-handlers} \doc{A list of actions that the user can invoke from the debugger in order to restart the computation at various places. Not normally manipulated by user code.} \fv{debug-level} \doc{The number of recursive debuggers we're inside. Zero for the top level. Not normally manipulated by user code.} \mc{catch-errors} {\lpar error-type $[$error-lambda $[$non-error-lambda$]]$\rpar \dt body} \doc{Evaluates \emph{body}. If an error which is a subtype of \emph{error-type} occurs, \df{\#f} is returned, unless \emph{error-lambda} is given, in which case it is called on the error object. If no error occurs then the result of evaluating \emph{body} is returned, unless \emph{non-error-lambda} is provided in which case it is called on the result of the evaluation of \emph{body} within the context of of the error handler, and the resultant value returned.} \mc{bind-error-handler}{\lpar error-type handler\rpar \dt body} \doc{This binds a handler to errors which are subtypes of \emph{error-type}. When such an error occurs, an appropriate error object is created and \emph{handler} is applied to it.} \op{invoke-debugger}{error} \doc{This error handler, when sent to an error object, invokes the debugger.} \op{remember-context}{error after-op} \doc{Used to make an error remember the context it occured in, so that even after the context has been exited the error can still be proceeded from, or the debugger can be entered back at the error context. This should always be called tail recursively from a handler, and after it stashes away the continuation it calls \emph{after-op} on \emph{error}. Of course, \emph{after-op} should never return.} \op{invoke-in-error-context}{error operation} \doc{Go back to the context in which \emph{error} occured and invoke \emph{operation} there.} \op{report}{error stream} \doc{Write a human readable account of the error to \emph{stream}. Controlled studies have shown that error messages can never be too verbose.} \op{proceed}{error value} \doc{Proceed from \emph{error}, returning \emph{value}. Of course, it is actually the call to \df{signal} that returns \emph{value}.} \op{signal}{error-type \dt args} \doc{This signals creates an error of type \emph{error-type} with initialization arguments \emph{args}. It then scans down \texttt{(fluid error-handlers)} until it finds a type of error which is a supertype of \emph{error-type}, at which point it sends the corresponding handler to the newly minted error object. If the handler returns, that value is returned by the call to \df{signal}. One day we'll add a way for a handler to refuse to handle an error, in which case the search for an applicable handler will proceed down the list.} \fv{error-handlers} \doc{An association list of mapping error types to error handlers. Users should not touch this directly.} Of course, there are a large number of types of errors used by the system. A few of the more useful to know about are: \ty{general-error} \doc{The supertype of all errors. Abstract.} \ty{proceedable-error} \doc{The supertype of all errors that can be recovered from. Abstract.} \ty{fs-error} \doc{File system error. Abstract. It has all kinds of subtypes for all the different possible file system error conditions.} \ty{error-opening} \doc{Abstract. Signaled when a file can't be opened for some reason. Proceeding from this kind of error with a string lets you try opening a different file.} \ty{operation-not-found} \doc{Signaled when an operation is sent to an object that can't handle it. Proceeding from this kind of error will return a value from the failed call.} \ty{nargs-error} \doc{Signaled when there are an incorrect number of arguments passed to a function. Proceeding from this will return a value from the failed call. Abstract} \ty{nargs-exact-error} \doc{Signaled when there are an incorrect number of arguments passed to a method that expects a particular number of arguments.} \ty{nargs-gte-error} \doc{Signaled when there are an insufficient number of arguments passed to a method that can tolerate extra arguments.} \ty{infinite-loop} \doc{Signaled when an infinite loop is entered. User programs may wish to signal this as well.} \ty{read-error} \doc{Some kind of reader syntax error. Abstract. There are about fifty million subtypes, corresponding to all the different constructs that can be malformed, and all the different ways in which they can be malformed. We probably went a little overboard with these.} \ty{user-interrupt} \doc{Oaklisp received a DEL signal. Through a convoluted series of events in which the UNIX trap handler sets the variable \df{\protect\_del\protect\_}, which is detected by the bytecode emulator which pretends that a \df{noop} instruction failed and passes the \df{nargs} register to the Oaklisp trap handler which salts the old \df{nargs} away for restoration upon return and signals this error type, the user usually lands in the debugger after typing Control-C.} \section{Numbers} Small integers (between $-2^{29}$ and $2^{29}-1$ inclusive) are represented as immediates of type \df{fixnum} and handled directly by microcode. When arithmetic instructions trap out, due to either their arguments not being \df{fixnum}s or to overflow, an Oaklisp operation corresponding to the bytecode is called. Most of these operations are written in terms of other bytecodes, and should never be shadowed. For instance, \begin{verbatim} (add-method (subtract/2 (number) x y) (+ x (- y))) \end{verbatim} defines subtraction in terms of negation and addition. The trap code also handles fixnum overflow, promoting the operands to \df{bignum}s and dispatching appropriately. The only really primitive operations, which must handle all types of numbers, are \df{<}, \df{=}, \df{minus}, \df{negative?}, \df{plus/2}, \df{times/2}, \df{/}, \df{/r}, \df{quotient}, \df{remainder}, \df{quotientm} and \df{modulo}. Whenever a new type of number is defined, methods for all of the above operations should be added for it, unless the new type is not a subtype of \df{real}, in which case methods wouldn't make sense for \df{<}, \df{negative?}, and perhaps \df{quotient}, \df{remainder}, \df{quotientm} and \df{modulo}. \section{Vectors and Strings} Rather than being built into the emulator, vectors are defined entirely within Oaklisp, albeit with some rather low level constructs. \ty{variable-length-mixin} \doc{This type provides a variable amount of stuff at the end of its instances. When a type has this mixed in, whether immediately or deep down in the inheritance tree, it always takes an extra initialization argument which says has long the variable length block at the end should be. This is mixed into such system types as \df{\%code-vector}, \df{stack-segment}, and \df{\%closed-environment}. In general, \df{variable-length-mixin} is used at the implementation level only and should never appear in user code. Typically if you think you want a subtype of \df{variable-length-mixin}, what you really want is an instance variable bound to a vector.} \lo{\%vref}{variable-length-object n} \doc{This is the accessor operation to get at the extra cells of subtypes of \df{variable-length-mixin}. It is used in the implementation of variable length structures, and in things like \df{describe} that look at their internals.} \ty{simple-vector} \doc{This is a subtype of \df{vector} with \df{variable-length-mixin} added and an appropriate \df{nth} method defined.} \discuss{Characters are packed into strings more densely than one character per reference, so strings are not just vectors with odd print methods; they also have accessor methods which unpack characters from their internals. Unfortunately, it is not possible to pack four eight bit characters into a single reference without violating the memory format conventions by putting something other than \framebox{\texttt{0 0}} in the tag field. We could pack four seven bit characters into each reference, but some computers use eight bit fonts, and the characters within the string would not be aligned compatibly with C strings. We therefore use the following somewhat wasteful format.} \ty{string} \doc{This is a subtype of \df{simple-vector} with the \df{nth} method shadowed by one that packs three eight bit characters into the low 24 bits of each fixnum, in littleendian order. The unused high bits of each word are set to zero to simplify equality testing and hash key computation. No trailing null character is required, although one is present two thirds of the time due to padding. Below is the string \texttt{"Oaklisp Rules!"} as represented in memory.} \begin{center} \begin{tabular}{|c|c|c|c|c|}\hline 31 \ldots 26 & 25 \ldots 18 & 17 \ldots 10 & 9 \ldots 2 & 1 0 \\\hline\hline \multicolumn{5}{|c|}\emph{string} \\\hline \multicolumn{4}{|c|}{\emph{object length:} 8} & 0 0 \\\hline \multicolumn{4}{|c|}{\emph{string length:} 14} & 0 0 \\\hline 0 0 0 0 0 0&\tt\#$\backslash$k &\tt\#$\backslash$a &\tt\#$\backslash$O&0 0 \\\hline 0 0 0 0 0 0&\tt\#$\backslash$s &\tt\#$\backslash$i &\tt\#$\backslash$l&0 0 \\\hline 0 0 0 0 0 0&\tt\#$\backslash$R &\tt\#$\backslash$space&\tt\#$\backslash$p&0 0 \\\hline 0 0 0 0 0 0&\tt\#$\backslash$e &\tt\#$\backslash$l &\tt\#$\backslash$u&0 0 \\\hline 0 0 0 0 0 0&\tt\#$\backslash$null&\tt\#$\backslash$! &\tt\#$\backslash$s&0 0 \\\hline \end{tabular} \end{center} \section{Symbols} We do not use any of the fancy techniques used by older dialects, like oblists or symbol buckets. Instead, the standard hash table facility is used for the symbol table. \heady{symbol-table}{}{Generic Hash Table} \doc{Maps strings to symbols, using \df{string-hash-key} to compute the hash and \df{equal?} to compare strings for equality.} \op{intern}{string} \doc{Returns a symbol with print name \emph{string} by looking it up in the \df{symbol-table} and making and installing a new symbol if it isn't found. Strings passed to \df{intern} should never be side effected afterwards or the symbol table could be corrupted.} \fv{print-escape} \doc{This flags whether symbols with weird characters in them should be with the weird characters escaped. It also applies to strings.} \fv{symbol-slashification-style} \doc{This flag is only relevent if \texttt{(fluid print-escape)} is on. With the value \df{t-compatible} then the empty symbol is printed as \texttt{\#[symbol ""]} and all other symbols requiring escaping are printed with a \texttt{$\backslash$} character preceding every character of the symbol. With any other value, escaped symbols are delimited by \texttt{|} characters and internal characters \texttt{$\backslash$} and \texttt{|} are preceded by \texttt{$\backslash$}.} \section{Variable Numbers of Arguments} \label{sec:varargs} The formal parameter list of a method is permitted to be improper, with the terminal atom being a magic token representing the rest of the arguments. The only legal use for this magic token is as the terminal member of an improper argument list of a tail recursive call, and as an argument to the special form \df{rest-length}. Methods that accept a variable number of arguments must exit tail recursively and must pass along their magic token in their tail recursive call, unless they know that they actually received no extra arguments. \sform{rest-length}{varargs-token} \doc{Returns the number of trailing arguments represented by \emph{varargs-token}.} For example, this is legal, \begin{verbatim} (define (okay x y . rest) (if (zero? (rest-length rest)) 'nanu-nanu (list 'you x y 'sucker . rest))) \end{verbatim} while the following are not, the first because it has an exit when there might be extra arguments which does not pass the extra arguments along tail recursively, and the second because it tries to pass along the extra arguments in a non tail recursive position. \begin{verbatim} (define (not-okay x y . rest) (if (eq? x y) 'nanu-nanu (list 'you x y 'sucker . rest))) (define (also-bad x y . rest) (append (list 'you x 'sucker . rest) y)) \end{verbatim} The implementation behind this is very simple: extra arguments are ignored by the compiler, except that it emits a \df{check-nargs-gte} in place of a \df{chech-nargs} at the top of the method code body and does a little computation to figure out what the value to put in the \df{nargs} register when it sees rest argument at the tail of a call. When all the user wishes to do is pass the extra arguments along in the way that the \df{make} method passes extra args along to \df{initialize}, this mechanism is both convenient and efficient. Sometimes the user needs to actually get into the extra arguments though, so some operations are provided to make handling variable numbers of arguments easier. \op{consume-args}{value \dt extra} \doc{Returns \emph{value}.} \op{listify-args}{operation \dt args} \doc{Calls \emph{operation} with a single argument, a list of \emph{args}.} There is also a macro package that implements optional and keyword arguments using these facilities, and the Scheme compatiblity package redefines \df{add-method} so that, as required by the Scheme standard \citep{R3RS}, extra arguments are made into a list. oaklisp-1.3.3.orig/doc/lim/methods.tex0000664000175000000620000001727707725515165016627 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Methods} In this chapter we describe how methods are created, represented, and looked up. This is intimately related to instance variable reference, so we describe how that works here as well. \subsection{Invoking Methods} Methods are looked up by by doing a depth first search of the inheritance tree. Some Oaklisp code to find a method would look like this, \begin{verbatim} (define (%find-method op typ) (let ((here (assq op (type-operation-method-alist typ)))) (if (null? here) (any? (lambda (typ) (%find-method op typ)) (type-supertype-list typ)) (list typ (cdr here))))) \end{verbatim} Once this information is found, we need to find the offset of the appropriate block of instance variables, put a pointer to the instance variable frame in the \df{bp} register, set the other registers correctly, and branch. \begin{verbatim} (define (%send-operation op obj) (let ((typ (get-type obj))) (destructure (found-typ method) (%find-method op typ) (set! ((%register 'current-method)) method) (set! ((%register 'bp)) (increment-locative (%crunch (%data obj) %loc-tag) (cdr (assq found-typ (type-bp-offset-alist typ))))) (set! ((%register 'env)) (method-env method)) (set! ((%register 'pc)) (code-body-instr (method-code (%method)))))) \end{verbatim} Of course, the actual code to find a method is written in C and has a number of tricks to improve efficiency. \begin{itemize} \item Simple lambdas (operations which have only one method defined at the type \df{object}) are ubiquitous, so the overhead of method lookup is avoided for them by having a \df{lambda?} slot in each operation. This slot holds a zero if no methods are defined for the given operation. If the only method defined for the operation is for the type \df{object} then the \df{lambda?} slot holds that method, and the method is not incorporated in the \df{operation-method-alist} of type \df{object}. If neither of these conditions holds, the \df{lambda?} slot holds \df{\#f}. \item To reduce the frequency of full blown method lookup, each operation has three slots devoted to a method cache. When \emph{op} is sent to \emph{obj}, we check if the \df{cache-type} slot of \emph{op} is equal to the type of \emph{obj}. If so, instead of doing a method search and finding the instance variable frame offset, we can use the cached values from \df{cache-method} and \df{cache-offset}. In addition, after each full blown method search, the results of the search are inserted into the cache. Giving the \dfsw{-M} switch to a version of the emulator compiled with \df{FAST} not defined will print an \texttt{H} when there is a method cache hit and an \texttt{M} when there is a miss. The method cache can be completely disabled by defining \df{NO\protect\_METH\protect\_CACHE} when compiling the emulator. We note in passing that we have one method cache for each operation. In contrast, the Smalltalk-80 \index{Smalltalk-80} system has an analogous cache at each call point. We know of no head to head comparison of the two techniques, but suspect that if we were to switch to the Smalltalk-80 technique we would achieve a higher average hit rate at considerable cost in storage. \item In order to speed up full blown method searches, a move to front heuristic reorders the association lists inside the types. In addition, the C code for method lookup was tuned for speed, is coded inline, and uses an internal stack to avoid recursion. \end{itemize} For most of this tuning we used the time required to compile \df{compile-bench.oak} as our primary benchmark for determining the speed of generic operations, since the compiler is written in a highly object-oriented style and makes extensive use of inheritance. \subsection{Adding Methods} A serious complication results from the fact that the type field in an \df{add-method} form is not evaluated until the method is installed at run time. Since the target type for the method is unknown at compile time the appropriate instance variable map is also unknown, and hence the correct instance variable offsets cannot be determined. Our solution is to have the compiler guess the order\footnote{The compiler guesses by attempting to evaluate the type expression at compile time.} or simply invent one, compile the offsets accordingly, and incorporate this map in the header of the emitted code block. When the \df{add-method} form is actually executed at run time, the assumed instance variable map is compared to the actual map for the type that is the recipient of the method, and the code is copied and patched if necessary. The code only needs to be copied in the rare case when a single \df{add-method} is performed on multiple types that require different offsets. After instance variable references in the code block have been resolved, which usually involves no work at all since the compiler almost always guesses correctly, the method can actually be created and installed. Creating the method involves pairing the code block with an appropriate environment vector containing references to variables that have been closed over. Because this environment vector is frequently empty, a special empty environment vector is kept in the global variable \df{\%empty-environment} so a new one doesn't have to be created on such occations. All other environment vectors are created by pushing the elements of the environment onto the stack and executing the \df{make-closed-environment} opcode. Environment vectors are never shared in our current implementation, with the exception of the empty environment. After the method is created it must be installed. The method cache for the involved operation is invalidated, and the method is either put in the \df{lambda?} slot of the operation or the \df{operation-method-alist} of the type it is being installed in. If there is already a value in the \df{lambda?} slot and the new method is not being installed for type \df{object}, the \df{lambda?} slot is cleared and the method that used to reside there is added to \df{operation-method-alist} of type \df{object}. \op{\%install-method-with-env}{type operation code-body environment} \doc{This flushes the method cache of \emph{operation}, ensures that the instance variable maps of \emph{code-body} and \emph{type} agree (possibly by copying \emph{code-body} and remapping the instance variable references), creates a method out of \emph{code-body} and \emph{environment}, and adds this method to the \df{operation-method-alist} of \emph{type}, modulo the simple lambda optimization if \emph{type} is \df{object}.} \op{\%install-method}{type operation code-body} \doc{\macdef{}{(\%install-method-with-env \emph{type operation code-body} \%empty-environment)}} \op{\%install-lambda-with-env}{code-body environment} \doc{\macdef{}{(\%install-method-with-env object (make operation) \emph{code-body environment})} but more efficient.} \op{\%install-lambda}{code-body} \doc{\macdef{}{(\%install-method-with-env object (make operation) \emph{code-body} \%empty-environment)} but more efficient.} oaklisp-1.3.3.orig/doc/lim/lim.tex0000664000175000000620000000247610752406631015727 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \documentclass[12pt]{report} % Blake McBride suggests [...,twoside]{book} \usepackage{times} \usepackage{fullpage} \usepackage{graphicx} \usepackage{makeidx} \usepackage[numbers]{natbib} \usepackage[hyphens]{url} \urlstyle{same} % \includeonly{cover,intro,language,dataform,bytecode,stack,oaklevel} \makeindex \begin{document} \input{../mandefs} \include{cover} \tableofcontents \newpage \pagenumbering{arabic} \include{intro} \include{language} \include{dataform} \include{bytecode} \include{stack} \include{methods} \include{oaklevel} \include{compiler} \include{boot} \include{admin} \bibliography{../oakman} \printindex \end{document} oaklisp-1.3.3.orig/doc/lim/bytecode.tex0000664000175000000620000002762207725515165016755 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Stack Machine Architecture} \section{Registers in the Emulator} This section describes the registers that make up the state of the bytecode emulator, called the processor below. \begin{description} \item[\tt pc:] The program counter points to a half reference address, and can not be accessed by register instructions. \item[\tt val\_stk:] The top of the value stack. Can not be accessed by register instructions. \item[\tt cxt\_stk:] The top of the context stack. Can not be accessed by register instructions. \item[\tt bp:] The base pointer points to the base of the instance variable frame of the current object. \item[\tt env:] The current environment object is indexed into to find locatives to lexically closed variables. \item[\tt current\_method:] The method whose code is currently being executed. This is maintained solely to simplify garbage collection and debugging. \item[\tt nargs:] The number of args register is set before a function call and checked as the first action within each function. \item[\tt t:] Holds the cannonical truth object, \texttt{\#t}. \item[\tt nil:] Holds the cannonical false object, \texttt{\#f}, which is also used as the empty list, \texttt{()}. \item[\tt fixnum\_type:] Holds the type of objects with a tag of fixnum. \item[\tt loc\_type:] Holds the type of objects with a tag of locative. \item[\tt subtype\_table:] Holds a table of the types of all the immediate subtypes. Currently only the first entry is used. \item[\tt cons\_type:] Holds the \emph{cons-pair} type, the type of simple conses which are directly manipulated by the processor. \item[\tt env\_type:] Holds that type of environment vectors, used when making new environment objects. \item[\tt object\_type:] Holds the type \emph{object} which is at the root of the type hierarchy. Used when calling an operation with no parameters. This should not be necessary in the next version. \item[\tt segment\_type:] Holds the type of stack segments, for use when the stack is being copied into the heap. \item[\tt argless\_tag\_trap\_table:] Holds a table of operations to be called when various instructions fail. \item[\tt arged\_tag\_trap\_table:] Holds a table of operations to be called when various instructions fail. \item[\tt boot\_code:] Holds the method to be called first thing at boot time. \item[\tt uninitialized:] Holds the value that gets stuck into newly allocated storage. \item[\tt free\_point:] Holds the point at which the next heap object will be allocated. Not accessed directly by even the most internal Oaklisp code, as the processor takes care of initialization and gc itself. \item[\tt new.end:] Holds the point at which we've run out of storage. An attempt to allocate past here necessitates a garbage collection. Not directly accessed by even the most internal Oaklisp code. \item[\tt next\_newspace\_size:] Holds the size in references of the next new space to be allocated by the garbage collector. This is dynamically adjusted by the garbage collector, so there is usually no need for it to be modified from the Oaklisp level. \end{description} \section{Instruction Set} The instructions follow the same argument order conventions as the language itself. For example, \texttt{(\df{store-loc} \emph{loc ref})} expects to get \emph{loc} on the top of the value stack and \emph{ref} below it. The instruction format \begin{center} \begin{tabular}{|c|c|c|}\hline 8 bits & 6 bits & 2 bits \\\hline inline argument & opcode & 0 0 \\\hline \end{tabular} \end{center} leaves eight bits for an inline argument. Instructions that do not require any inline argument actually have ``argless instruction'' in their instruction field and use the argument field to code for the actual instruction. Some instructions, eg.\ \df{load-imm}, require a complete arbitrary reference as an inline argument. This in incorporated, aligned, directly in the instruction stream. See section \ref{sec:codeblock} for details. Other instructions, in particular the long branches, require more than an eight bit inline argument but do not need an entire reference. These instructions get a 14 bit inline argument by using the space where the next instruction would normally go, with the last two bits set to zero in case the argument ends up in the low half of a word. \newenvironment{itable}[1]{ \begin{center} \par \nopagebreak #1 \par \nopagebreak \begin{tabular}{|l|c|l|l|l|} \hline \emph{instruction} & \emph{inline arg} & \emph{initial stack} & \emph{final stack} & \emph{extra cell args} \\\hline\hline}{\hline\end{tabular}\end{center}} \newcommand{\icomment}[1]{\multicolumn{5}{|l|}{\parbox{4in}{#1}}\\\hline} \begin{itable}{Arithmetic} \df{plus} & & 2 (fix,fix) & 1 (fix) & \\ \hline \df{minus} & & 1 (fix) & 1 (fix) & \\ \hline \df{subtract} & & 2 (fix,fix) & 1 (fix) & \\ \hline \df{times} & & 2 (fix,fix) & 1 (fix) & \\ \hline \df{mod} & & 2 (fix,fix) & 1 (fix) & \\ \hline \df{div} & & 2 (fix,fix) & 1 (fix) & \\ \hline \df{log-op} & n (4 bits) & 2 (fix,fix) & 1 (fix) & \\ \hline \df{bit-not} & & 1 (fix) & 1 (fix) & \\ \hline \df{rot} & & 2 (fix,fix) & 1 (fix) & \\ \hline \df{ash} & & 2 (fix,fix) & 1 (fix) & \\ \hline \end{itable} \begin{itable}{Predicates} \df{eq?}& & 2 (ref,ref) & 1 (bool) & \\ \hline \df{not}& & 1 (ref) & 1 (bool) & \\ \hline \df{<0?}& & 1 (fix) & 1 (bool) & \\ \hline \df{=0?}& & 1 (fix) & 1 (bool) & \\ \hline \df{=} & & 2 (fix,fix) & 1 (bool) & \\ \hline \df{<} & & 2 (fix,fix) & 1 (bool) & \\ \hline \end{itable} \begin{itable}{Control} \df{branch} & rel-addr & & & \\ \hline \df{branch-nil} & rel-addr & 1 (ref) & & \\ \hline \df{branch-t} & rel-addr & 1 (ref) & & \\ \hline \df{long-branch} & & & & 0.5\\ \hline \df{long-branch-nil} & rel-addr & 1 (ref) & & 0.5\\ \hline \df{long-branch-t} & rel-addr & 1 (ref) & & 0.5\\ \hline \df{return} & & & & \\ \hline \end{itable} \begin{itable}{\df{catch} and \df{call/cc} Related} \df{filltag} & & 1 (tag) & 1 (tag) & \\ \hline \df{throw} & & 2 (tag,ref) & 1 (ref) & \\ \hline \df{fill-continuation}& & 1 (photo) & 1 (photo) & \\ \hline \df{continue} & & 2 (photo,ref) & 1 (ref) & \\ \hline \end{itable} \begin{itable}{Stack Manipulation} \icomment{All stack references are zero-based. \texttt{(swap 0)} is a noop. \texttt{(blast $n$)} \meq \texttt{(store-stack $n$)(pop 1)}.} \df{pop} & n & n (refs) & & \\ \hline \df{swap} & n & n (refs) & n (refs) & \\ \hline \df{blast} & n & n (refs) & n-1 (refs) & \\ \hline \df{blt-stack}& n,m & n+m (refs) & n (refs) & \\ \hline \icomment{8 bit ref splits to 4-bit n and m, which are $1 \ldots 16$.} \end{itable} \begin{itable}{Register Manipulation} \df{store-reg} & register & 1 (ref) & 1 (ref) & \\ \hline \df{load-reg} & register & & 1 (ref) & \\ \hline \end{itable} \begin{itable}{Addressing Modes} \df{store-env} & offset & 1 (ref) & 1 (ref) & \\ \hline \df{store-stack} & offset & 1 (ref) & 1 (ref) & \\ \hline \df{store-bp} & offset & 1 (ref) & 1 (ref) & \\ \hline \df{store-bp-i} & & 2 (fix,ref) & 1 (ref) & \\ \hline \df{contents} & & 1 (loc) & 1 (ref) & \\ \hline \df{set-contents} & & 2 (loc,ref) & 1 (ref) & \\ \hline \icomment{The next two instructions are the same.} \df{load-glo}& & & 1 (ref) & 1 (ref)\\ \hline \df{load-imm}& & & 1 (ref) & 1 (ref)\\ \hline \df{load-imm-fix} & n & & 1 (fix) & \\ \hline \df{load-env} & offset & & 1 (ref) & \\ \hline \df{load-stack} & offset & & 1 (ref) & \\ \hline \df{load-bp} & offset & & 1 (ref) & \\ \hline \df{load-bp-i} & & 1 (fix) & 1 (ref) & \\ \hline \icomment{Make a locative to the location $offset$ in beyond the \df{bp} register:} \df{make-bp-loc} & offset & & 1 (loc) & \\ \hline \df{locate-bp-i} & & 1 (fix) & 1 (loc) & \\ \hline \end{itable} \begin{itable}{Memory Model and Tag Cleaving} \df{get-tag} & & 1 (ref) & 1 (fix) & \\ \hline \df{get-data} & & 1 (ref) & 1 (fix) & \\ \hline \df{crunch} & & 2 (fix,fix:tag)& 1 (ref) & \\ \hline \df{load-type} & & 1 (ref) & 1 (ref:type) & \\ \hline \df{load-length} & & 1 (ref) & 1 (fix) & \\ \hline \icomment{The next two instructions are not currently used.} \df{peek} & & 1 (fix) & 1 (fix:16-bit) & \\ \hline \df{poke} & & 2 (fix,fix:16-bit)&1 (fix:16-bit)&\\ \hline \end{itable} \begin{itable}{Misc} \df{check-nargs} & n & 1 (op) & & \\ \hline \df{check-nargs-gte} & n & 1 (op) & & \\ \hline \df{store-nargs} & n & & & \\ \hline \df{noop} & & & & \\ \hline \df{allocate} & & 2 (typ,len) & 1 (ref) & \\ \hline \df{vlen-allocate}& & 2 (typ,len) & 1 (ref) & \\ \hline \df{funcall-tail} & & 2 (op,obj) & 1 (op,obj) & \\ \hline \df{funcall-cxt-br}& rel-addr& 2 (op,obj) & 1 (op,obj) & \\ \hline \df{push-cxt} & rel-addr & & & \\ \hline \df{push-cxt-long} & & & & 0.5\\ \hline \df{big-endian?} & & & 1 (bool) & \\ \hline \df{object-hash}& & 1 (ref) & 1 (fix) & \\ \hline \df{object-unhash}& & 1 (fix) & 1 (ref) & \\ \hline \df{gc} & & & 1 (ref) & \\ \hline \df{full-gc} & & & 1 (ref) & \\ \hline \df{inc-loc} & & 2 (loc,fix) & 1 (loc) & \\ \hline \end{itable} \begin{itable}{List related instructions} \df{cons} & & 2 (ref,ref) & 1 (ref) & \\ \hline \df{reverse-cons} & & 2 (ref,ref) & 1 (ref) & \\ \hline \df{car} & & 1 (pair) & 1 (ref) & \\ \hline \df{cdr} & & 1 (pair) & 1 (ref) & \\ \hline \df{set-car} & & 2 (pair,ref) & 1 (ref) & \\ \hline \df{set-cdr} & & 2 (pair,ref) & 1 (ref) & \\ \hline \df{locate-car} & & 1 (pair) & 1 (loc) & \\ \hline \df{locate-cdr} & & 1 (pair) & 1 (loc) & \\ \hline \df{assq} & & 2 (ref,alist)& 1 (ref:pair/nil)& \\ \hline \end{itable} \section{Weak Pointers} \label{sec:weak} Weak pointers allow users to maintain tenuous references to objects, in the following sense. Let $\alpha$ be a weak pointer to the object \emph{foo}, found by executing the code \texttt{(object-hash \emph{foo})}. This $\alpha$ can be dereferenced to yield a normal reference, \evto{(object-unhash $\alpha$)}{\emph{foo}}. However, if there is no other way to get a reference to \emph{foo} then the system is free to invalidate $\alpha$, so \evto{(object-unhash $\alpha$)}{\#f}. In practice, when the garbage collector sees that there are no references to \emph{foo} except for weak pointers it reclaims \emph{foo} and invalidates any weak pointers to it. Weak pointers are implemented directly by bytecodes because the emulator handles all details of storage allocation and reclamation directly. Weak pointers are represented by integers. Each time call call the \df{object-hash} is made the argument is looked up in the \emph{weak pointer hash table}. If no entry is found, a counter is incremented and the value of that counter is returned. An entry is made in the \emph{weak pointer table} at an index corresponding to the current value of the counter, so that the weak pointer can be used to get back the original reference, and an entry is make in the weak pointer hash table to ensure that if the weak pointer to the same object is requested twice, the same number will be returned both times. After a garbage collection the weak pointer table is scanned and entries to objects which have been reclaimed are discarded, the weak pointer hash table is cleared, and the data in the weak pointer table is entered into the weak pointer hash table. Although these algorithms are poor if objects with weak pointers to them are frequently reclaimed, in practice this has not been a problem. oaklisp-1.3.3.orig/doc/lim/stack.tex0000664000175000000620000001566610752406631016260 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Stack Discipline} This chapter describes how the stacks are organized at the logical level: how temporaries are allocated, how functions call and return work, how escape objects (used in the implementation of catch and throw) work, and how stack snapshots (used in the implementation of call/cc) work. \section{Stack Overview} The Oaklisp bytecode machine has a two-stack architecture. The \emph{value stack} contains arbitrary references and is used for storing temporary variables, passing arguments, and returning results. The \emph{context stack} is used for saving non-variable context when calling subroutines. Only context frames are stored on the context stack. This two stack architecture makes tail recursion particularly fast, and is in large part responsible for the speed of function call in this implementation. Most of the bytecodes are the usual sort of stack instructions, and use only value stack, for instance \df{plus} and \texttt{(swap $n$)}\index{\texttt{swap}}. All arguments are passed on the value stack, and the value stack is \emph{not} divided into frames. Methods consume their arguments, returning when they have replaced their arguments with their result or tail recursing when they have replaced their arguments with the appropriate arguments to the operations they are tail recursing to. Under the current language definition there is no multiple value return, although the bytecode architecture admits such a construct. There are facilities for variable numbers of arguments, which are described in section \ref{sec:varargs}. \newenvironment{stackphoto}{\begin{center}\begin{tabular}{|c|} $\vdots$\\\hline}{\end{tabular}\end{center}} \section{Method Invocation/Return} When a method is to be invoked, the arguments and operation are assembled on the value stack in right to left order, ie.\ the rightmost argument is pushed first and the operation is pushed last. Let us walk through the invokation of \texttt{(f x y z)}, where \texttt{f} is on operations which is being passed three arguments. Since we evaluate right to left, first we push \texttt{z}, thus: \begin{stackphoto} \tt z \\\hline \end{stackphoto} continuing, we push the rest of the arguments and the operation, until the stack is of this form. \begin{stackphoto} \tt z \\\hline \tt y \\\hline \tt x \\\hline \tt f \\\hline \end{stackphoto} A \df{(store-nargs 3)} instruction is now executed to place the number of arguments in the \df{nargs} register, and one of the \df{funcall} instructions is executed, which variant depending on whether this is a tail recursive call. If this is not a tail recursive call, the \df{funcall} instruction first pushes a frame containing the contents of the \df{current\protect\_method}, \df{bp} and \df{env} registers and a return \df{pc} onto the context stack. The instruction then examines the top two values, \texttt{f} and \texttt{x}, and looks \texttt{f} up in the \df{operation-method-alist} of the type of \texttt{x}, potentially also scanning the supertypes until it finds the appropriate method to be invoked. This method is placed in the \df{current\protect\_method} register, the method's environment is placed in the \df{env} register, the \df{pc} is set to the beginning of the method's code block, and the address of the appropriate instance variable frame within \texttt{x} is placed in the \df{bp} register. The \df{funcall} instruction leaves the value stack and \texttt{nargs} register unchanged: \begin{stackphoto} \tt z \\\hline \tt y \\\hline \tt x \\\hline \tt f \\\hline \end{stackphoto} The first thing the code block of the resultant method executes is one of the \df{check-nargs} instructions, in this case perhaps {\tt (\df{check-nargs} 3)}. A \texttt{(\df{check-nargs} $n$)} instruction tests if \df{nargs} is $n$, trapping if not. After that, it pops the operation \texttt{f} off the stack. By leaving the operation to be popped off by the \df{check-nargs} instruction rather than the \df{funcall} instruction, when an an incorrect number of arguments is detected the operation is still available to the error system. The \df{return} instruction pops the top frame off the context stack, loads the popped context into the processor, and continues execution. Before a \df{return} is executed all of the arguments have been consumed and the result is the only thing left on the stack, \begin{stackphoto} (f x y z) \\\hline \end{stackphoto} \section{The Context Stack} The only things that can be stored on the context stack are context frames, which each have four values, as shown below. The \df{push-cxt} instruction pushes a context frame onto the context stack. It takes an inline argument, which is the relative address of the desired return point. This allows a context to be pushed whenever convenient, perhaps before the assembly of arguments begins. Earlier in the implementation process there was only one variant of the \df{funcall} instruction, which was tail recursive. Non tail recursive calls were compiled as a \df{push-cxt} followed by a \df{funcall-tail}, but because this sequence occured so frequently a combined instruction was implemented to improve code density. \begin{stackphoto}\hline \tt \df{pc} \\ \hline \tt \df{bp} \\ \hline \tt \df{env} \\\hline \tt \df{current\protect\_method} \\\hline\hline \tt pc \\ \hline \tt bp \\ \hline \tt env \\\hline \tt current\_method \\\hline\hline \tt pc \\ \hline \tt bp \\ \hline \tt env \\\hline \tt current\_method \\\hline \end{stackphoto} Actually, the \df{pc} stored in the context stack is not a raw pointer to the next instruction but rather the offset from the beginning of the current code block, stored as a fixnum. This makes the \df{return} instruction slightly slower, as the actual return pc must be recomputed, but simplifies the garbage collector. The \df{bp} is analogously stored with a tag of \df{locative} so that the garbage collector need not treat it specially. This would cause a problem if the current object were reclaimed and afterwards had one of its instance variables refered to, as all that would be left of the object would be the solitary cell that the saved bp was pointing to, and the rest of the relevent instance variable frame would be gone. This is avoided by having the compiler ensure that a reference to the object in question is retained long enough. oaklisp-1.3.3.orig/doc/lim/boot.tex0000664000175000000620000000707207725515165016117 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Bootstrapping} In this chapter we describe new versions of Oaklisp are created. Essentially, the process is quite similar to the way in which a C program is created. First the Oaklisp source files which make up the \emph{cold world load} are compiled to produce object files. Then a linker, originally written in T but now an Oaklisp program, takes these object files and lays them all out in memory, resolving references to global variables and laying out quoted constants refered to in the code. The linker also puts a map of where it allocated various globals and such in memory. At this point, the cold world (named \df{oaklisp.cold}) is booted, and the files that the linker layed out in memory are thereby executed, sequentially. These files gradually build all the infrastructure required for a full Oaklisp world. The first files are written at an extremely low level, and make things like \df{make} and \df{cons} work. Later files bring up more advanced constructs, until finally there is enough for object files to be loaded. At this point the world is dumped to \df{oaklisp.ol}, and then this world is booted and has files loaded into it using the normal file loading mechanisms until the full Oaklisp world, \df{oaklisp.olc}, is built. The formats of these files is very simple. They contain a header which gives the length of the various segments and the values of some registers. This is followed by a memory image, with pointers given as offsets from the beginning of the image. This is followed by the weak pointer table. The cold world is in a hexidecimal format, with each reference represented as a space followed by a sequence of hexidecimal digits. Carriage returns may optionally preceed spaces. Actually, the space referred to above can be either a space character or the \upar\ character. The later indicates that the following reference contains bytecodes. Since bytecodes are ordered differently depending on the endianity of the machine, the hex format world loader swaps the two instructions on little endian machines but not on big endian machines. This keeps the cold load file independent of endianity. The warm world loads are in a binary format and are not independent of endianity. For this reason, warm world extensions start with \df{.ol} for big endian versions and \df{.lo} for little endian versions. The emulator replaces the characters \texttt{\%\%} in the command line file argument (or the default world in \df{config.h}) with either \texttt{ol} or \texttt{lo}, depending on whether \df{BIG\protect\_ENDIAN} is defined. To make Oaklisp dump itself upon exiting use the \dfsw{-d} \dfsw{-b} switches when invoking Oaklisp. After Oaklisp has exited, the emulator will prompt for a filename to dump the world image to, unless this filename has been provided with the \dfsw{-f}~\emph{filename} switch. Usually the \dfsw{-G} switch is also given when the world is being dumped. oaklisp-1.3.3.orig/doc/lim/Makefile0000664000175000000620000000207507725515165016070 0ustar barakstaff# This file is part of Oaklisp. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html # or from the Free Software Foundation, 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA all: lim.dvi SRC = admin.tex boot.tex bytecode.tex compiler.tex cover.tex \ dataform.tex intro.tex language.tex lim.tex methods.tex \ oaklevel.tex stack.tex lim.dvi: $(SRC) ../mandefs.tex -rm lim.ind -latex lim all: lim.pdf SRC = admin.tex boot.tex bytecode.tex compiler.tex cover.tex \ dataform.tex intro.tex language.tex lim.tex methods.tex \ oaklevel.tex stack.tex lim.pdf : lim.dvi dvipdfm lim lim.dvi: $(SRC) ../mandefs.tex -del lim.ind -latex lim }{number1 number2} \op{>=}{number1 number2} \op{ash-left}{integer1 integer2} \op{ash-right}{integer1 integer2} \op{bit-and}{integer1 integer2} \op{bit-andca}{integer1 integer2} \op{bit-equiv}{integer1 integer2} \op{bit-nand}{integer1 integer2} \op{bit-nor}{integer1 integer2} \op{bit-not}{integer} \op{bit-or}{integer1 integer2} \op{bit-xor}{integer1 integer2} \op{object-unhash}{integer} \op{positive?}{number} \op{quotient}{number1 number2} \op{rot-left}{fixnum1 fixnum2} \op{rot-right}{fixnum1 fixnum2} \op{minus}{number} \op{modulo}{number1 number2} \op{negative?}{number} The following operations are also open-coded and take type-mismatch traps if necessary. They can be add-method'ed to, but only for types that are not handled by the microcode. It should be clear from the discussion below which types the bytecode expects. \op{throw}{tag value} \doc{Causes control to return from the \df{native-catch} form that generated \emph{tag}.} \lo{contents}{locative} \doc{Dereferences \emph{locative}. \texttt{((setter contents) \emph{locative} \emph{value})} puts \emph{value} in the cell pointed to by \emph{locative}.} \op{object-unhash}{fixnum} \doc{Returns the object that the weak pointer \emph{fixnum} points to, or \df{\#f} if the object has been reclaimed by the garbage collector.} The following operations are open-coded, and the microcode can handle objects of any type, so they can't be \df{add-method}'ed. \op{get-type}{object} \doc{Returns the type of \emph{object}.} \op{eq?}{x y} \doc{Determines whether \emph{x} and \emph{y} are the same object. Implemented by checking if the references are identical.} \op{object-hash}{x} \doc{Returns a ``weak pointer'' to \emph{x}.} \op{cons}{x y} \doc{Conses \emph{x} onto \emph{y} in the usual lisp fashion.} \op{identity}{x} \doc{Returns \emph{x}.} \op{list}{\dt args} \doc{Constructs a list; \macdef{(list \emph{a} \emph{b} \emph{c})}{(cons \emph{a} (cons \emph{b} (cons \emph{c} '()))).} Actually, the \df{list} operation is open coded and has \df{backwards-args-mixin} mixed into the type, so its arguments are pushed onto the stack in left to right order. The code emitted for the operation itself is just a {\tt (load-reg nil)} followed by a bunch of \df{reverse-cons} instructions, one for each argument.} \op{list*}{$a_1 \ldots a_n$} \doc{\macdef{}{(cons $a_1 \ldots$ (cons $a_{n-1}$ $a_n$) $\ldots$).} This is open coded in nearly the same way as \df{list}.} \op{not}{x} \doc{\macdef{}{(eq? \emph{x} \#f)}} \op{null?}{x} \doc{\macdef{}{(eq? \emph{x} '())}} \op{second-arg}{x y \dt rest} \doc{Returns \emph{y}. Remember, Oaklisp does not guarantee any particular order of evaluation of arguments.} The following operations are open-coded, but the microcode traps out if the arguments are not simple cons cells. They can not be \df{add-method}'ed to for the type \df{cons-pair}. \lo{car}{pair} \lo{cdr}{pair} \lo{caar}{pair} \lo{cadr}{pair} \lo{cdar}{pair} \lo{cddr}{pair} \lo{caaar}{pair} \lo{caadr}{pair} \lo{cadar}{pair} \lo{caddr}{pair} \lo{cdaar}{pair} \lo{cdadr}{pair} \lo{cddar}{pair} \lo{cdddr}{pair} \lo{caaaar}{pair} \lo{caaadr}{pair} \lo{caadar}{pair} \lo{caaddr}{pair} \lo{cadaar}{pair} \lo{cadadr}{pair} \lo{caddar}{pair} \lo{cadddr}{pair} \lo{cdaaar}{pair} \lo{cdaadr}{pair} \lo{cdadar}{pair} \lo{cdaddr}{pair} \lo{cddaar}{pair} \lo{cddadr}{pair} \lo{cdddar}{pair} \lo{cddddr}{pair} \section{Subprimitives} The following operations should be used only deep within the system. Unless otherwise noted below, when a subprimitive encounters a domain error normal Oaklisp code is not trapped to. Rather, you're lucky if the system dumps core. \op{\%assq}{object alist} \doc{Does the usual association list lookup, but assumes that \emph{alist} is made out of simple cons pairs. Passing it lazy lists or things like that will crash the system.} \oop{\%big-endian?} \doc{Returns {\tt\#t} or {\tt\#f} depending on whether instructions are ordered starting at the high half of a reference or the low half of a reference, respectively. On all machines that I know of, this is the same as the endianity of bytes.} \op{\%continue}{stack-photo} \doc{Resumes \emph{stack-photo}, abandoning the current stack.} \op{\%fill-continuation}{empty-stack-photo} \doc{Fills in the template stack snapshot \emph{empty-stack-photo} with the appropriate information, copying sections of the stack into the heap where necessary, and returns its argument.} \op{\%filltag}{empty-catch-tag} \doc{Fills in \emph{empty-catch-tag} with the current stack heights.} \op{\%crunch}{data tag} \doc{Returns a reference with the data portion \emph{data} and a tag of \emph{tag}. Traps if either argument is not a fixnum.} \op{\%data}{x} \doc{Returns the non-tag field of \emph{x} as a fixnum.} \op{\%tag}{x} \doc{Returns the tag of \emph{x} as a fixnum.} \oop{\%gc} \doc{Forces an immediate normal garbage collection.} \oop{\%full-gc} \doc{Forces an immediate full garbage collection. At the end of the full garbage collection, new space size is set back to its original value.} \op{\%get-length}{x} \doc{Returns the number of storage cells occupied by \emph{x}. Zero for immediates.} \op{\%increment-locative}{locative n} \doc{Returns a locative to the cell \emph{n} beyond the cell pointed to by \emph{locative}.} \lo{\%load-bp-i}{n} \doc{Loads the contents of self's instance variable number \emph{n}. Not for the squeamish, as who is really ``self'' and who would be self except that the compiler is compiling away intermediate lambdas is very implementation specific.} \op{\%make-cell}{value} \doc{Returns a locative to a new cell containing \emph{value}. Could be defined with \texttt{(define (\%make-cell x) (make-locative x))}.} \op{\%make-closed-environment}{$a_1 \ldots a_n$} \doc{Returns a new environment containing $a_1 \ldots a_n$. At least one object is required. To get an empty environment, look in \df{\%empty-environment}.} \op{\%print-digit}{n} \doc{Prints \emph{n} as a single decimal digit to \df{stdout}. Used to indicate various error conditions during the boot process.} \op{\%push}{\dt args} \doc{Pushes \emph{args} onto the stack, returning (so to speak) the leftmost argument. This would be about the same as \texttt{values}, if we had multiple value return.} \oop{\%read-char} \doc{Returns a character read from \df{stdin}. No buffering. For use by the cold load stream.} \oop{\%return} \doc{Generates the \df{return} bytecode. Doesn't push anything onto the stack. Will corrupt the stack unless you really know what you are doing.} \op{\%allocate}{type size} \doc{Allocates a block of storage \emph{size} long, filling in the type field with \emph{type}. \emph{Type} should not be variable length.} \op{\%varlen-allocate}{type size} \doc{Allocates a block of storage \emph{size} long, filling in the type field with \emph{type} and the size field with \emph{size}. \emph{Type} should be a variable length type. Using this instead of \df{\%allocate} where appropriate avoids a window of gc vulnerability.} \op{\%write-char}{char} \doc{Writes the character \emph{char} to \df{stdout}. No buffering or anything.} \op{\%{\protect\upar}super-tail}{type operation object} \doc{Generates the \df{{\protect\upar}super-tail} bytecode, passing it appropriate arguments. This is used only used in the implementation of \df{{\protect\upar}super}. Once the compiler is modified to handle the \df{{\protect\upar}super} construct directly this will no longer be needed.} \section{Defined Types} The following types are completely defined in Lisp. \ty{object} \doc{This type is the top of the inheritance hierarchy. Ordinary functions are installed as methods for this type.} \ty{type} \doc{New types are generated by instantiating this type.} \ty{variable-length-mixin} \doc{This mixin allows each instance of a type to have a vector of anonymous cells tacked on the end. It also provides several low-level methods for indexed references into such vectors. Currently, the only variable-length types are \df{vector}, \df{\%code-vector} and \df{\%closed-environment}.} \ty{open-coded-mixin} \doc{If this is mixed in to an operation, the compiler will send it a \df{get-byte-code-list} message, and use the result instead of a regular function call whenever the operation appears in a program.} \ty{pair} \ty{cons-pair} \ty{null-type} \ty{vector} \ty{operation} \ty{settable-operation} \ty{locatable-operation} \ty{\%method} \ty{\%code-vector} \ty{\%closed-environment} \ty{locale} \ty{general-error} \ty{foldable-mixin} \section{Defined Operations} The methods for these operations are written in low level Oaklisp. \op{apply}{operation $a_1 \ldots a_n$ arglist} \doc{Calls \emph{operation} with arguments $a_1 \ldots a_n$ and the contents of \emph{arglist}. For instance, \evto{(apply + 1 2 '(3 4))}{10}.} \op{make}{type \dt args} \doc{Returns a new instance of \emph{type} that has been initialized by sending it an \df{initialize} message with the extra arguments \emph{args} passed along.} \op{\%install-method-with-env}{type operation code-body environment} \doc{Adds the specified method to the search table of \emph{type}. It returns \emph{operation}, since this is what some instances of \df{add-method} are compiled into. Methods that don't close over anything can refer to \df{\%empty-environment}, whose value is an environment object whose vector portion has length zero. It takes care of instance variable mapping conflicts.} \op{initialize}{object} \doc{Returns \emph{object}. This no-op is what is shadowed when you define \df{initialize} methods for new types. \texttt{(initialize \emph{type} \emph{supertype-list} \emph{ivar-list})} does the work involved in making a new type. The list of supertypes is used to make a list of all ancestors that is searched at run time to find methods for operations. The ancestor tree is considered to be ordered from bottom to top and from left to right while constructing this list, and duplicates are removed. An error is generated if more than one top-wired type is found in the resulting ancestor list. The instance-variable map of the type is created, with any top-wired type appearing at the beginning, and \df{variable-length-mixin} appearing at the end if it is present. Any method you define to handle an \df{initialize} message should return \df{self}.} \op{dynamic-wind}{before-op main-op after-op} \doc{Calls the operation \emph{before-op}, calls the operation \emph{main-op}, calls the operation \emph{after-op}, and returns the value returned by \emph{main-op}. If \emph{main-op} is exited abnormally, \emph{after-op} is called automatically on the way out. Similarly, if \emph{main-op} is entered abnormally, \emph{before-op} is called automatically on the way in.} \op{call-with-current-continuation}{operation} \doc{Calls \emph{operation} with one argument, the current continuation. The synonym \df{call/cc} is provided for those who feel that \df{call-with-current-continuation} is excessively verbose.} oaklisp-1.3.3.orig/doc/lim/dataform.tex0000664000175000000620000005036611036617630016743 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \chapter{Internal Data Format} This chapter describes how memory and tags are set up, and how this implements the object semantics of the language. \section{Tag Types} \label{immtags} In an effort to reduce the complexity of the bytecode interpreter and to simplify the system in general, there are only four tag types. Tags are stored in the two low order bits of each reference thus simplifying tag manipulation, particularly in the presence of indexed addressing modes. \begin{center} \begin{tabular}{|c|c|c|l} \cline{1-3} \em 31 30 29 28 27 26 \ldots 11 10 9 8 & \em 7 6 5 4 3 2 & \em 1 0 & \multicolumn{1}{l}\emph{type} \\ \cline{1-3} \multicolumn{2}{|c|}{twos complement integer} & 0 0 & fixnum \\ \cline{1-3} data & subtype & 1 0 & other immediate type \\ \cline{1-3} \multicolumn{2}{|c|}{address} & 0 1 & locative (pointer to cell) \\ \cline{1-3} \multicolumn{2}{|c|}{address} & 1 1 & reference to boxed object \\ \cline{1-3} \end{tabular} \end{center} This tagging scheme, along with our object format, does not allow for \emph{arbitrarily} scannable heaps (in which the divisions between objects can be figured out starting the scan at any point in the heap.) In fact, if solitary cells are permitted, as they are in our implementation, scanning the heap starting at the begining is not even possible. However, our garbage collector never needs to scan the heap in such a fashion. Note that there is no extra ``gc'' bit in every word, but again, our garbage collector requires no such bit. \section{Other Immediate Types} References with a tag of \framebox{1 0} use the next six bits to specify a subtype. \begin{center} \begin{tabular}{|c|c|c|c|c|l} \cline{1-5} \emph{31 \ldots 24} & \emph{23 \ldots 16} & \emph{15 \ldots 8} & \emph{7 \ldots 2} & \emph{1 0} & \multicolumn{1}{l}\emph{type} \\ \cline{1-5} reserved & font & ascii code & 0 0 0 0 0 0 & 1 0 & character\\ \cline{1-5} \end{tabular} \end{center} Character is currently the only ``other immediate type.'' More may be added later, in particular Macintosh handles. (At one time weak pointers were represented as their own immediate type, but they are now represented using integers for compatibility with the Scheme standard \citep{R3RS}.) \section{Memory Structure} Memory is a linear array of \emph{cells}, 32-bit aligned words. These cells are divided into two contiguous chunks: free cells and allocated cells. The \emph{free pointer} points to the division between these two chunks, and it is incremented as memory is allocated. When allocating an object would push the free pointer beyond the limits of memory, a garbage collection is performed. The allocated portion of memory is divided into \emph{aggregate objects} and \emph{solitary cells}. Each aggregate object is a contiguous chunk of cells. The first cell of an object is a reference to its type; if the type is \emph{variable length}, the second cell holds the length of the object, including the first two cells. The remainder of the cells hold the instance variables. Solitary cells are cells that are not part of any object, but are the targets of locatives. Solitary cells are used heavily in the implementation of mutable variables. A reference to an object consists of a pointer to that object with a tag of \emph{boxed-object}. References to solitary cells are locatives. Furthermore, locatives may reference cells that are the instance variables of objects. If such an object is ever deallocated by the garbage collector, all of the cells making up the object are made free \emph{except} for those cells that are referenced by locatives, which are not deallocated. These become solitary cells. \section{Representation of Specific Types} Consider an object of type \emph{foo}, which is based on \emph{bar} and \emph{baz}. \emph{Bar} had instance variables \texttt{bar-1} and \texttt{bar-2}, baz has instance variables \texttt{baz-1}, \texttt{baz-2} and \texttt{baz-3}, and \emph{foo} has instance variable \texttt{foo-1}. \emph{Foo} inherits the instance variables of the types it is based on, but methods defined for type \emph{foo} can not refer to these inherited variables. Each type's local instance variables are stored contiguously, and in order of lexical definition, in instances of that type, and of types that inherit it; this allows variable reference to instance variables to be resolved into offsets from the start of the relevent instance variable frame at compile time. Here is an instance of \emph{foo} as it might actually be stored in memory: \begin{center} \begin{tabular}{|c|} \hline reference to type \emph{foo} \\ \hline\hline value of \texttt{foo-1} \\ \hline\hline value of \texttt{baz-1} \\ \hline value of \texttt{baz-2} \\ \hline value of \texttt{baz-3} \\ \hline\hline value of \texttt{bar-1} \\ \hline value of \texttt{bar-2} \\ \hline \end{tabular} \end{center} Observe that instances of type \emph{foo} are divided into contiguous chunks of instance variables, each inherited from a different supertype. When a type inherits another type through two different routes, it still only inherits the instance variables once.\footnote{This aspect of the language is in flux, and should not be relied upon by users.} Furthermore, if the instance variables of two types inherited by a third have the same names they are still distinct instance variables.\footnote{This is in marked contrast to ZetaLisp flavors--that's why variable references in flavors go through mapping tables, resulting in considerable overhead. There are also important modularity considerations in favor of our scheme which are beyond the scope of this document, but are discussed in detail in \citep{SNYDER86}.} These semantics allow us to reference instance variables very quickly, once the local instance variable block has been located. It also allows us to use the same compiled code for a single method regardless of whether it is being invoked upon an instance of the type it was added to or on an instance of an inheriting type. \section{System Types} This section describes the format of various objects that are directly referenced by the microcode,\footnote{Our microcode is C.} such as code vectors and catch tags. It should be emphasized that these system objects are full-fledged objects. They have types which can be inherited and have their methods overridden, just like any other object. The only ``magic'' thing about these types is that their local instance variables (ie. the system ones) must live at the top of their memory representation, even when inherited. This allows the microcode to locate the values it needs without going through the type heirarchy. The only constraint this places on the user is that a type may not inherit two types both of which are \emph{top-wired}, for obvious reasons. For example, it is impossible to make a type whose instances are both operations and types. \subsection{Methods} A method has two instance variables which hold the code object containing the code that implements the method and the environment vector that holds references to variables that were closed over.\footnote{Well, not all closed over variables. Only ones above the locale level. Locale variable references are implemented as inline references to value cells.} \subsection{Environment Vectors} Environment vectors have a block of cells, each of which contains a locative to a cell. When the running code needs to reference a closed-over variable, it finds the location of the cell by indexing into the environment vector. This index is calculated at compile time, and such references consume only one instruction. Just as it is possible for a number of methods to share the same code, differing only in the associated environment, it is also possible for a number of methods to share the same environment, differing only in the associated code. Currently the compiler does not generate such sophisticated constructs. \subsection{Code Vectors} \label{sec:codeblock} Code lives in vectors of integers, which are interpreted as instructions by the bytecode emulator. This format allows code to be stored in the same space as all other objects, and allows the garbage collector to be ignorant of its existance, treating code vectors like any other vector. Bytecodes are 16 bits long, with the low 2 bits always 0. Here is an example of some stuff taken from the middle of a code vector. \begin{center} \begin{tabular}{|c|c|c|c|c|c|} \multicolumn{6}{|c|}{$\vdots$}\\\hline 8 bit inline arg & 6 bit opcode & 0 0 & 8 bit inline arg & 6 bit opcode & 0 0 \\\hline \multicolumn{2}{|c|}{14 bit instruction} & 0 0 & 8 bit inline arg & 6 bit opcode & 0 0 \\\hline \multicolumn{2}{|c|}{14 bit relative address} & 0 0 & 8 bit inline arg & 6 bit opcode & 0 0 \\\hline 8 bit inline arg & 6 bit opcode & 0 0 & 8 bit inline arg & 6 bit opcode & 0 0 \\\hline \multicolumn{2}{|c|}{14 bit instruction} & 0 0 & \multicolumn{2}{c|}{14 bit instruction} & 0 0 \\\hline \multicolumn{6}{|c|}{arbitrary reference used by last instruction of previous word} \\\hline \multicolumn{2}{|c|}{14 bit instruction} & 0 0 & 8 bit inline arg & 6 bit opcode & 0 0 \\\hline \multicolumn{6}{|c|}{$\vdots$} \end{tabular} \end{center} Note the arbitrary reference right in the middle of code. To allow the garbage collector to properly handle code vectors, as well as to allow the processor to fetch the cell efficiently, this reference must be cell aligned. When the processor encounters an instruction that requires such an inline argument, if the pc is not currently pointing to an aligned location then the pc is suitably incremented. This means that the assembler must sometimes emit a padding instuction, which will be ignored, between instructions that require inline arguments and their arguments. An alternative that was used earlier in the design process was to mandate that all instructions requiring inline arguments occur in a position where the following reference can be fetched without realigning the pc. This requires sometimes inserting a padding \texttt{noop} before an instruction that requires an inline argument, and analysis showed that the time required to process a \df{noop} instruction is much greater than the time required to check if the low bit of a register is on and increment that register if so. \subsection{Endianity} The logical order of the instructions in a code vector depends on the endianity of the CPU running the emulator. If the machine is big endian, ie.\ addresses start at the most significant and of a word and go down (eg.\ a 68000 or an IBM 370) then instructions are executed left to right in the picture above. Conversely, on a littleendian machine (eg.\ a VAX) instructions are executed right to left. Of course, the Oaklisp loader has to be able to pack instructions into words in the appropriate order. The format of cold world loads is insensitive to endianity, but binary world loads are sensitive to it, so binary worlds are distributed in both big endian (with extensions beginning with \df{.ol}) and little endian (with extensions beginning with \df{.lo}) versions. \oop{\%big-endian?} \doc{This returns the endianity of the machine that Oaklisp is running on. Endianity is determined by the order in which instructions are fetched, in other words, the order of two 16-bit words within a 32-bit word. This returns true if the first instruction fetched is from the more significant half.} \subsection{Stack Implementation} \label{sec:stackimpl} Although the value and context stacks are logically contiguous, they are sometimes physically discontinuous. The instructions all assume that stacks live in a designated chunk of memory called the stack buffer. They check if they are about to overflow or enderflow the stack buffer, and if so they take appropriate actions to fill or flush it, as appropriate, before proceeding. If the stack buffer is about to overflow, most of it is copied to a \emph{stack segment} which is allocated on the heap. These overflown segments form a linked list, so upon stack underflow the top segment is removed from this list and copied back to the stack buffer. There is one more circumstance in which the stack buffer is flushed. The \df{call/cc} construct of Scheme \citep{R3RS} is implemented in terms of \emph{stack photos,} which are snapshots of the current state of the two stacks, and which can be restored in the future. A \df{fill-continuation} instruction forces the stack buffers to be flushed and then copies references to the linked lists of overflow segments into a continuation object. Actually, in the above treatment we have oversimplified the concept of flushing a stack buffer. The emulator constant \df{MAX\protect\_SEGMENT\protect\_SIZE} determines the maximum size of any flushed stack segment. When flushing the stack, if the buffer has more than that number of references then it is flushed into a number of segments. This provides some hysteresis, speeding \df{call/cc} by taking advantage of coherence in its usage patterns. A possibility opened by our stack buffer scheme, which we do not currently exploit, is that of using virtual memory faults to detect stack buffer overflows, thus eliminating the overhead of explicitly checking for stack overflow and underflow. As a historical note, an early version did not use a stack buffer but instead implemented stacks as linked lists of segments which always lived in the heap. When pushing over the top of a segment, a couple references were copied from the top of that segment onto a newly allocated segment, providing sufficient hysteresis to prevent repeated pushing and poping along a segment boundary from incurring inordinate overhead. Regretably, substantial storage is wasted by the hysteresis and the overflow and underflow limits vary dynamically wereas in the new system these limits are C link-time constants. Presumably due to these factors, in spite of its old world charm, timing experiments between the old system and the new system were definitive. \subsection{Escape Objects} \label{sec:ctagform} In our implementation of Oaklisp we provide two different escape facilities: \df{call/cc} and \df{catch}. The \df{call/cc} construct is that described in the Scheme standard \citep{R3RS}. The \df{catch} facility provides with user with a second class \emph{catch tag}, which is valid only within the dynamic extent of the \df{catch}. The implementation of catch tags is very simple: they contain heights for the value and context stacks. When a catch tag is thrown to, the value and context stacks are chopped off to the appropriate heights. The slot \df{saved-wind-count} is used for unwind protection and \df{saved-fluid-binding-list} is used for fluid variables. Details are given in sections \ref{sec:oakcatch} and \ref{sec:oakwind}. \begin{center} \begin{tabular}{|c|}\hline \emph{type:} escape-object \\\hline \emph{value stack height:} 25 \\\hline \emph{context stack height:} 19 \\\hline \emph{saved wind count:} 3 \\\hline \emph{saved fluid binding list:} \tt ((print-length . \#f) \ldots)\\\hline \end{tabular} \end{center} Actually, there are two variants of \df{catch}. In the regular variant, which is compatible with T, the escape object is invoked by calling it like a procedure, as in \texttt{(catch a (+ (a 'done) 12))}. In the other variant, the escape object is not called but rather thrown to using the \df{throw} operation, as in \texttt{(native-catch a (+ (throw a 'done) 12))}. Although the latter construct is slightly faster, the real motivation for its inclusion is to remind the user that the the escape object being thrown to is not first class. In order to ensure that an escape object is not used outside of the extent of its dynamic validity, references to them should not be retained beyond the appropriate dynamic context. \subsection{Types} Type objects are used when tracing up the type heirarchy in order to find appropriate methods and bp offsets. Since the types are used to find methods, they must be system objects so that reference to their instance variables can be done without sending them explicit messages. The \df{operation-method-alist} maps from operations to methods handled by the type itself, not any supertype. The \df{type-bp-alist} maps from types to offsets which are where the appropriate frame of instance variables may be found. The microengine uses a simple move-to-front heuristic in an attempt to reduce the overhead of searching these alists. The \df{supertype-list} contains a list of the immediate supertypes. Supertypes by inheritance that have instance variables are present in \df{type-bp-alist}, however. This is a picture of the \df{cons-pair} type, as it actually appears in memory: \begin{center} \begin{tabular}{|c|c|} \hline \multicolumn{2}{|c|}\emph{type} \\\hline \emph{instance-length:} & 3 \\\hline \emph{variable-length?:} & \texttt{\#f} \\\hline \emph{supertype-list:} & \texttt{(\emph{pair} \emph{object})}\\\hline \emph{ivar-list:} & \texttt{(the-car the-cdr)} \\\hline \emph{ivar-count:} & 2 \\\hline \emph{type-bp-alist:} & \texttt{((\emph{cons-pair} . 1))} \\\hline \emph{operation-method-alist:} & \texttt{((\emph{car} . \emph{meth}) $\ldots$)}\\\hline \emph{top-wired?:} & \texttt{\#f} \\\hline \end{tabular} \end{center} \section{Storage Reclamation} Our garbage collector \citep{PEARLMUTTER99} is a variant of Baker's algorithm, a so-called ``stop and copy'' collector. The spaces to be reclaimed are renamed \emph{old}, all accessible objects in the old spaces are transported to a new space, and the old spaces are reclaimed. The data present in the initial world is considered ``static'' and is not part of old space in normal garbage collections, only in ``full'' garbage collections, which also move everything not reclaimed into static space. Due to locatives, the collector makes an extra pass over the data; a paper with more complete details on this latter complication is in press. The weak pointer table is scanned at the end of garbage collection, and references to deallocated objects are discarded. The user interface to the garbage collector is quite simple. Normally, the user need not be concerned with storage reclamation; upon the exhaustion of storage, the garbage collector is automatically invoked. When this happens some messages are printed; these messages can be supressed with the \dfsw{-Q} switch. The default size of new space is 1Mb, or 256k references. This can be altered with the \dfsw{-h} \emph{size} switch, where \emph{size} is measured in bytes. The operations \df{\%gc} and \df{\%full-gc} invoke the garbage collector explicitly. Programs that use weak pointers can be effected by garbage collection; for details, see section \ref{sec:weak}. The \dfsw{-G} switch indicates that if and when the world is dumped, and if Oaklisp terminates with an exit code of zero, a full garbage collection should be performed. In full garbage collections preceding world dumps, the root set does not include the stacks. New space is resized dynamically, being expanded to \df{RECLAIM\protect\_FRACTION} times the amount of unreclaimed data if the fraction of unreclaimed data is above more than one \df{RECLAIM\protect\_FRACTION}'th of new space after a normal garbage collection, or by the minimal amount needed if there is insufficient space available in new space to fulfill the allocation request that triggered the collector. Currently \df{RECLAIM\protect\_FRACTION} is two. The \df{next\protect\_newspace\protect\_size} register says how big the next new space allocated will be, and is accessible to Oaklisp code. Its value should not be lowered casually, as the garbage collector will fail if new space is too small to hold all of the non-reclaimed storage from old space. A full garbage collection sets the size of new space back to the value originally specified by the user when Oaklisp was invoked, or the default value if none was specified. oaklisp-1.3.3.orig/doc/mandefs.tex0000664000175000000620000000632607735462572016015 0ustar barakstaff% This file is part of Oaklisp. % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2 of the License, or % (at your option) any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % The GNU GPL is available at http://www.gnu.org/licenses/gpl.html % or from the Free Software Foundation, 59 Temple Place - Suite 330, % Boston, MA 02111-1307, USA \bibliographystyle{plainnat} \DeclareGraphicsExtensions{.ips} \newcommand{\df}[1]{{\tt#1}\index{{\tt#1}}} \newcommand{\dffl}[1]{{\tt(fluid #1)}\index{{\tt#1} ! fluid}} \newcommand{\dfcoer}[1]{{\tt(coercer #1)}\index{{\tt#1} ! coercer}} \newcommand{\dfsw}[1]{{\tt#1}\index{{\tt#1} ! switch}} \newenvironment{docenv}{\nopagebreak\vspace{-4ex}\nopagebreak \begin{quotation}\noindent}{\end{quotation}} \newcommand{\doc}[1]{\nopagebreak\vspace{-4ex}\nopagebreak \begin{quotation}\noindent#1\end{quotation}} \newcommand{\discbar}{\rule{3in}{.2mm}} \newenvironment{discussenv}{\begin{quote}\begin{quote}\discbar\par}{\par\discbar\end{quote}\end{quote}} \newcommand{\discuss}[1]{\begin{discussenv}#1\end{discussenv}} \newcommand{\macdef}[2]{{\tt#1}\ \meq\ {\tt#2}\newline} \newcommand{\evto}[2]{{\tt#1}\ \ra\ {\tt#2}} \newcommand{\header}[2]{\par\noindent\hspace{\leftmargini }{#1}\hfill\emph{#2}\hspace*{\leftmargini}\newline} \newcommand{\heady}[3]{\index{{\tt#1} ! #3}\header{{\tt#1 \emph{#2}}}{#3}} \newcommand{\headyy}[3]{\index{{\tt#1} ! #3}\header{{\tt(#1 \emph{#2}\tt)}}{#3}} \newcommand{\sform}[2]{\headyy{#1}{#2}{Special Form}} \newcommand{\op}[2]{\headyy{#1}{#2}{Operation}} \newcommand{\so}[2]{\headyy{#1}{#2}{Settable Operation}} \newcommand{\lo}[2]{\headyy{#1}{#2}{Locatable Operation}} \newcommand{\mc}[2]{\headyy{#1}{#2}{Macro}} \newcommand{\fn}[2]{\headyy{#1}{#2}{Function}} \newcommand{\pr}[2]{\headyy{#1}{#2}{Predicate}} \newcommand{\spred}[2]{\headyy{#1}{#2}{Settable Predicate}} \newcommand{\gv}[1]{\heady{#1}{}{Global Variable}} \newcommand{\ob}[1]{\heady{#1}{}{Object}} \newcommand{\ty}[1]{\heady{#1}{}{Type}} \newcommand{\cty}[1]{\heady{#1}{}{Coercable Type}} \newcommand{\fv}[1]{\index{{\tt#1} ! Fluid Variable}\header{\tt (fluid #1)}{Fluid Variable}} \newcommand{\makin}[2]{\index{{\tt#1} ! Making}\header{\tt (make #1 \emph{#2}\tt)}{Operation}} \newcommand{\setter}[3]{\index{{\tt#1} ! Setter}\header{\tt(set! (#1 \emph{#2}\tt) \emph{#3}\tt)}{Operation}} \newcommand{\coercer}[2]{\index{{\tt#1} ! Coercer}\header{\tt((coercer #1) \emph{#2}\tt)}{Coarcable Type}} \newcommand{\oop}[1]{\index{{\tt#1} ! Operation}\header{\tt(#1)}{Operation}} \newcommand{\ra}{$\Rightarrow$} \newcommand{\meq}{$\equiv$} \newcommand{\upar}{$\uparrow$} \newcommand{\dt}{{\tt~.~}} \newcommand{\lpar}{{\tt(}} \newcommand{\rpar}{{\tt)}} % % These give ^ and _. Numbers for other characters are in the font % % tables at the back of the texbook. % \newcommand{\h}{\char'136\relax} % \newcommand{\w}{\char'137\relax} \newcommand{\bang}[0]{\texttt{!}} \newcommand{\ie}{\emph{i.e.}} oaklisp-1.3.3.orig/man/0002775000175000000620000000000011036654362013644 5ustar barakstaffoaklisp-1.3.3.orig/man/man1/0002775000175000000620000000000011036654362014500 5ustar barakstaffoaklisp-1.3.3.orig/man/man1/oaklisp.10000664000175000000620000001357710752412032016225 0ustar barakstaff.TH OAKLISP 1 .SH NAME oaklisp \- An implementation of the Oaklisp language \" This file is part of Oaklisp. \" \" This program is free software; you can redistribute it and/or modify \" it under the terms of the GNU General Public License as published by \" the Free Software Foundation; either version 2 of the License, or \" (at your option) any later version. \" \" This program is distributed in the hope that it will be useful, \" but WITHOUT ANY WARRANTY; without even the implied warranty of \" MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the \" GNU General Public License for more details. \" \" The GNU GPL is available at http://www.gnu.org/licenses/gpl.html \" or from the Free Software Foundation, 59 Temple Place - Suite 330, \" Boston, MA 02111-1307, USA .SH SYNOPSIS .B oaklisp [ emulator-options ... [ -- oaklisp-options ... ]] .SH DESCRIPTION .I Oaklisp is an object-oriented dialect of Scheme. This implementation is quite portable, compiling to a virtual machine which is emulated by a C program. Nevertheless, reasonable speed is achieved through a variety of sophisticated techniques. .SH OPTIONS Options are all long, and it makes no difference if you start them with one or two dashes (`-'). All options can be abbreviated to a unique prefix. There are two sorts of options: for the bytecode emulator, and for the Oaklisp world. You must use a -- to separate them. .SS EMULATOR OPTIONS .TP .B \-help Show summary of emulator options .TP .B \-world file file is world to load .TP .B \-dump file dump world to file upon exit .TP .B \-d file synonym for --dump .TP .B \-dump-base b 0=ascii, 2=binary; default=2 .TP .B \-predump-gc b 0=no, 1=yes; default=1 .BR .TP .B \-size-heap n n is in kilo-refs, default 128 .TP .B \-size-val-stk n value stack buffer, n is in refs .TP .B \-size-cxt-stk n context stack buffer, n is in refs .TP .B \-size-seg-max n maximum flushed segment len, n is in refs .BR .TP .B \-trace-gc v 0=quiet, 3=very detailed; default=0 .TP .B \-verbose-gc v synonym for --trace-gc .TP .B \-trace-traps .TP .B \-trace-files trace filesystem operations .SS UNOPTIMIZED EMULATOR OPTIONS .TP .B \-trace-segs trace stack segment writes/reads .TP .B \-trace-valcon print entire value stack at each instr .TP .B \-trace-cxtcon print entire context stack at each instr .TP .B \-trace-stks print the size of the stacks at each instr .TP .B \-trace-instructions trace each bytecode executed .TP .B \-trace-methods trace each method lookup .TP .B \-trace-mcache trace method cache .SS OAKLISP OPTIONS .TP .B \-help Show summary of Oaklisp options .TP .B \-eval expr Evaluate Oaklisp expression, which is one arg so be sure to quote for shell. .TP .B \-load file Load a file. .TP .B \-compile file Compile file.oak yielding file.oa .TP .B \-locale x Switch to locale x, eg system-locale (default), compiler-locale, scheme-locale (for RnRS compatibility). .TP .B \-exit Exit upon processing this option. .SH EXAMPLES This will compile the file myfile.oak in the scheme locale and then leave the user in a read-eval-print loop in the scheme locale. .B oaklisp -- -locale scheme-locale -compile myfile .SH ENVIRONMENT The environment variable OAKWORLD will override the default compiled into the executable, but itself can be overridden on the command line. .SH FILES /usr/lib/oaklisp/oakworld.bin holds the world image. It is portable between machines of the same endianity. The location can vary depending upon installation-time decisions. .SH BUGS Floating point numbers are not implemented. Rationals can be used to make up for this lack because rationals can be told to print in floating point format and floating point format input can be made to read as rational numbers. (There are a couple floating point implementations, but they are not merged into the distributed release.) In contrast to the error handling system, which is Industrial Strength, the debugger is virtually nonexistent. There is no foreign function interface for loading and calling C routines from a running Oaklisp. (Again, there are a couple implementations of foreign function interfaces which are not merged in.) The memory format does not support uninterpreted "blobs". Porting the system to 64-bit machines has not been done, and would be quite difficult. POSIX threads in the emulator never got quite finished. Bug reports and enhancements should be sent to barak@cs.may.ie. .SH REFERENCES The programs are documented more fully in the language and implementation manuals included with the distribution. In binary packages these are probably in /usr/share/doc/oaklisp/lang.pdf and lim.pdf. The Oaklisp home page is transitioning from .I http://www.bcl.hamilton.ie/~barak/oaklisp/ to .I http://oaklisp.alioth.debian.org/. .I The Implementation of Oaklisp is a chapter in .I Topics in Advanced Language Implementation edited by Peter Lee, pp 189-215, MIT Press, 1991. .I Oaklisp: an Object-Oriented Dialect of Scheme appears in the journal .I Lisp and Symbolic Computation 1(1):39-51, published by Klewer Associates, May 1988. .I Oaklisp: an Object-Oriented Scheme with First Class Types appeared in proceedings of the ACM conference OOPSLA-86, pp30-37, published as a special issue of .I SIGPLAN Notices. .I Garbage collection with pointers to single cells, an article on the Oaklisp garbage collector, appeared in .I Communications of the ACM, 39(12):202-206 (online edition), December 1996. .I The Revised^n Report on Scheme is a useful piece of documentation, and is widely available online. .SH DISTRIBUTION The .I Oaklisp copyright belongs to its authors. It is distributed under the .I GNU General Public License, a copy of which is included in the source distribution in the file .I COPYING. For further information or to make alternate arrangements please contact the authors, who are surprisingly reasonable people. .SH AUTHOR Oaklisp was originally designed, implemented, and documented by Barak A. Pearlmutter and Kevin J. Lang. oaklisp-1.3.3.orig/man/Makefile0000664000175000000620000000160107725515165015307 0ustar barakstaff# This file is part of Oaklisp. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # The GNU GPL is available at http://www.gnu.org/licenses/gpl.html # or from the Free Software Foundation, 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA # This value of prefix will usually be overridden prefix=/usr/local d=$(DESTDIR)$(prefix)/share/man/man1 .PHONY: all install clean all: install: mkdir --parents $d cp -a man1/oaklisp.1 $d/ clean: