From a27cc2ac7bf6a0ad60cc6c9f949a988d0444bb4e Mon Sep 17 00:00:00 2001 From: dos-reis Date: Mon, 28 Jan 2008 04:16:25 +0000 Subject: * boot/Makefile.pamphlet: Remove. * boot/translator.boot: New. * boot/translator.boot: Remove. * boot/tokens.boot: New. * boot/tokens.boot.pamphlet: Remove. * boot/scanner.boot: New. * boot/scanner.boot.pamphlet: Remove. * boot/pile.boot: New. * boot/pile.boot.pamphlet: Remove. * boot/parser.boot: New. * boot/parser.boot.pamphlet: New. * boot/initial-env.lisp: New. * boot/initial-env.lisp.pamphlet: Remove. * boot/includer.boot: New. * boot/includer.boot.pamphlet: Remove. * boot/ast.boot: New. * boot/ast.boot.pamphlet: Remove. --- src/boot/initial-env.lisp | 205 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 205 insertions(+) create mode 100644 src/boot/initial-env.lisp (limited to 'src/boot/initial-env.lisp') diff --git a/src/boot/initial-env.lisp b/src/boot/initial-env.lisp new file mode 100644 index 00000000..d256e7c4 --- /dev/null +++ b/src/boot/initial-env.lisp @@ -0,0 +1,205 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007-2008, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;; + + +;; +;; Abstract: +;; This file defines the base initial environment for building +;; a Boot translator image. It essentially etablishes a namespace +;; (package BOOTTRAN) for the Boot translator, and defines +;; some macros that need to be present during translation of Boot +;; source files. +;; + +(defpackage "BOOTTRAN" + (:use "AxiomCore") + #+:common-lisp (:use "COMMON-LISP") + #-:common-lisp (:use "LISP")) + + +(in-package "BOOTTRAN") + +;## need the conditional here so it appears in boottran +#+:ieee-floating-point (defparameter $ieee t) +#-:ieee-floating-point (defparameter $ieee nil) + +(defmacro memq (a b) + `(member ,a ,b :test #'eq)) + +(defvar *lisp-bin-filetype* "o") + +(defvar *lisp-source-filetype* "lisp") + +(defun setdifference (x y) + (set-difference x y)) + +(defun make-cvec (sint) + (make-string sint)) + +(defun MAKE-VEC (n) + (make-array n)) + +(defun concat (&rest l) + (progn + (setq l (mapcar #'string l)) + (apply #'concatenate 'string l))) + +(defun |shoeInputFile| (filespec ) + (open filespec :direction :input :if-does-not-exist nil)) + +(defmacro |shoeOpenInputFile| + (stream fn prog) + `(with-open-file (,stream ,fn :direction :input + :if-does-not-exist nil) ,prog)) + +(defmacro |shoeOpenOutputFile| + (stream fn prog) + `(with-open-file (,stream ,fn :direction :output + :if-exists :supersede) ,prog)) + +(defun shoeprettyprin1 (x &optional (stream *standard-output*)) + (let ((*print-pretty* t) + (*print-array* t) + (*print-circle* t) + (*print-level* nil) + (*print-length* nil)) + (prin1 x stream))) + +(defun reallyprettyprint (x &optional (stream *terminal-io*)) + (shoeprettyprin1 x stream) (terpri stream)) + +(defun shoeprettyprin0 (x &optional (stream *standard-output*)) + (let ((*print-pretty* nil) + (*print-array* t) + (*print-circle* t) + (*print-level* nil) + (*print-length* nil)) + (prin1 x stream))) + +(defun shoenotprettyprint (x &optional (stream *terminal-io*)) + (shoeprettyprin0 x stream) + (terpri stream)) + +(defun make-full-cvec (sint &optional (char #\space)) + (make-string sint :initial-element (character char))) + +(defun |shoePLACEP| (item) + (eq item nil)) + +(defun substring (cvec start length) + (if length + (subseq cvec start (+ start length)) + (subseq cvec start))) + +(defun MAKE-HASHTABLE (id1) + (let ((test (case id1 + ((EQ ID) #'eq) + (CVEC #'equal) + ((UEQUAL EQUAL) #'equal) + (otherwise (error "bad arg to make-hashtable"))))) + (make-hash-table :test test))) + +(defun HKEYS (table) + (let (keys) + (maphash #'(lambda (key val) + (declare (ignore val)) + (push key keys)) table) + keys)) + + +(defun HPUT (table key value) + (setf (gethash key table) value)) + +(defun QENUM (cvec ind) + (char-code (char cvec ind))) + +(defun charmem (a b) + (member a b :test #'eql)) + +(defun |shoeIdChar| (x) + (or (ALPHANUMERICP x) + (charmem x '(#\' #\? #\%)))) + +(defun |shoeStartsId| (x) + (or (alpha-char-p x) + (charmem x '(#\$ #\? #\%)))) + +(defun strpos (what in start dontcare) + (setq what (string what) in (string in)) + (if dontcare + (progn + (setq dontcare (character dontcare)) + (search what in :start2 start + :test #'(lambda (x y) (or (eql x dontcare) + (eql x y))))) + (search what in :start2 start))) + + +(defun strposl (table cvec sint item) + (setq cvec (string cvec)) + (if (not item) + (position table cvec + :test #'(lambda (x y) (position y x)) + :start sint) + (position table cvec + :test-not #'(lambda (x y) (position y x)) + :start sint))) + +(defun VEC-SETELT (vec ind val) + (setf (elt vec ind) val)) + +(defun bvec-make-full (n x) + (make-array (list n) + :element-type 'bit + :initial-element x)) + +(defun make-bvec (n) + (bvec-make-full n 0)) + +(defun bvec-setelt (bv i x) + (setf (sbit bv i) x)) + +(defun size (l) + (cond ((vectorp l) (length l)) + ((consp l) (list-length l)) + (t 0))) + +(defun identp (a) + (and (symbolp a) a)) + +(defun |shoeReadLisp| (s n) + (multiple-value-list (read-from-string s nil nil :start n))) + +(defun |last| (x) + (car (last x))) -- cgit v1.2.3