From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- cl-support/PORTING | 105 ++++ cl-support/README | 3 + cl-support/cl-definitions.lisp | 1351 ++++++++++++++++++++++++++++++++++++++++ cl-support/cl-init.lisp | 170 +++++ cl-support/cl-setup.lisp | 30 + cl-support/cl-structs.lisp | 699 +++++++++++++++++++++ cl-support/cl-support.lisp | 86 +++ cl-support/cl-types.lisp | 90 +++ cl-support/wcl-patches.lisp | 68 ++ 9 files changed, 2602 insertions(+) create mode 100644 cl-support/PORTING create mode 100644 cl-support/README create mode 100644 cl-support/cl-definitions.lisp create mode 100644 cl-support/cl-init.lisp create mode 100644 cl-support/cl-setup.lisp create mode 100644 cl-support/cl-structs.lisp create mode 100644 cl-support/cl-support.lisp create mode 100644 cl-support/cl-types.lisp create mode 100644 cl-support/wcl-patches.lisp (limited to 'cl-support') diff --git a/cl-support/PORTING b/cl-support/PORTING new file mode 100644 index 0000000..2114be5 --- /dev/null +++ b/cl-support/PORTING @@ -0,0 +1,105 @@ +Here are the steps involved in porting to a new Common Lisp implementation. + +(0) Find the executable you want to use. If possible, use an image + that doesn't have stuff like CLX, CLOS, a snazzy editor, and the + like loaded, since we don't use any of that stuff. + + Put an environment variable in the haskell-development script to point + to the lisp you want to run. + +(1) You must add appropriate conditionalizations to cl-init.lisp and + cl-definitions.lisp in this directory. Look for places where there + are #+ things for the other dialects. + + As a matter of style, try to make an explicit case for each Lisp + instead of using #- to test for it *not* being a particular dialect. + This will prevent confusion on future ports. + + You may also need/want to add conditionals to the primitive + implementation files in the runtime directory. + + Do not add #+/#- conditionalizations to any other random .scm + files, since we want to keep this implementation-dependent stuff + centralized. + +(2) Make subdirectories to hold compiled files in each of the source + directories. The name of the subdirectory must match the constant + lisp-implementation-name in cl-definitions.lisp. + +(3) Try compiling the Haskell system (by loading cl-init.lisp) and + fix any compilation warnings that happen. (Hopefully there won't + be any.) + + You probably want to build a system initially with the default + compiler settings and verbose compiler diagnostics. This will make + any problems that show up later easier to debug. Also, it is + helpful to capture all the messages in a dribble file to make it + easier to verify that everything went OK. + +(4) Try compiling the prelude using (compile/prelude *prelude-unit*). + You need to create a subdirectory in the progs/prelude directory + to hold the output files, and define $PRELUDEBIN to point at + this directory (see the haskell-setup script). + + The important thing at this point is that the prelude makes it all + the way through the codegen phase and produces Lisp code. Don't worry + too much now if the Lisp compiler has trouble digesting the output. + + Once you get to this stage, it's time to start messing with + compiler optimize proclamations. We generally use (speed 3) and + (safety 0). Also, you should figure out how to suppress any + compiler messages (e.g., set *compile-print* and *compile-verbose* + to false). We usually leave *compile-verbose* on during compilation + of the Haskell compiler, but turn it off later so that people don't + get messages from the Lisp compiler when running Haskell programs. + +(5) Make a subdirectory in the com directory and make the following set + of scripts there: + + clean -- remove all binary files. Also change the main com/clean + script to invoke this. + compile -- recompile everything with the right compiler flags (see + step 5). + build-prelude -- run the prelude through the haskell compiler. + This should save the old compiled prelude files as old-prelude.* + case something goes wrong. + savesys -- load the compiled prelude and save a core file. + This should also be careful not to overwrite an existing file. + + Look at the scripts that have already been written for other Lisps + for hints. + + At some point you also need to put a README file in this directory. + + +(6) Now it's time to get serious about getting the prelude to compile. + Use the clean, compile, and build-prelude scripts you just wrote. + + Some compilers have a hard time dealing with the large pieces of + Lisp code produced for the prelude. You will probably need to do + something to make the heap bigger. (And, make sure the machine + you are using to do the build on has plenty of swap space.) You + may also need to tweak the chunk-size parameters to force the + output to be split up into smaller pieces. + + It's OK to leave the prelude interface file as a source file, or + to compile it with low speed optimizations. On the other hand, + the prelude code file ought to be processed with as many speed + optimizations as possible. + +(7) Build a new executable using the "savesys" script and take it for + a test drive. + +(8) You must also hack the emacs interface file, emacs-tools/haskell.el, + to recognize when it's gotten into the debugger or break loop. + To test your new executable with the emacs stuff, you must + define the environment variable HASKELLPROG to point at it, or + set the emacs variable haskell-program-name. + +(9) If you want to use the Haskell->CLX interface, you'll have to + mess with equivalents of the build-xlib and savesys-xlib scripts. + There is some system-dependent code in xlibclx.scm to set up an + error handler -- make sure you have conditionalized this appropriately + for your Lisp system. + + diff --git a/cl-support/README b/cl-support/README new file mode 100644 index 0000000..5553e4a --- /dev/null +++ b/cl-support/README @@ -0,0 +1,3 @@ +This directory contains Common-Lisp-syntax files to set up a more +Scheme-like environment. Load cl-init.lisp and it will suck in all +the rest. diff --git a/cl-support/cl-definitions.lisp b/cl-support/cl-definitions.lisp new file mode 100644 index 0000000..8727679 --- /dev/null +++ b/cl-support/cl-definitions.lisp @@ -0,0 +1,1351 @@ +;;; cl-definitions.lisp -- mumble compatibility package for Common Lisp +;;; +;;; author : Sandra Loosemore +;;; date : 11 Oct 1991 +;;; +;;; You must load cl-setup and cl-support before trying to compile this +;;; file. + +(in-package "MUMBLE-IMPLEMENTATION") + + +;;;===================================================================== +;;; Syntax +;;;===================================================================== + +(define-mumble-import quote) +(define-mumble-import function) + +;;; Lambda lists have to have dot syntax converted to &rest. + +(define-mumble-macro mumble::lambda (lambda-list &rest body) + `(function (lambda ,(mung-lambda-list lambda-list) ,@body))) + +(defun mung-lambda-list (lambda-list) + (cond ((consp lambda-list) + (let ((last (last lambda-list))) + (if (null (cdr last)) + lambda-list + `(,@(ldiff lambda-list last) ,(car last) &rest ,(cdr last))))) + ((null lambda-list) + '()) + (t + `(&rest ,lambda-list)))) + + +;;; We only funcall and apply things that are real functions. + + +;;; Gag. Lucid needs to see the procedure declaration to avoid putting +;;; a coerce-to-procedure check in, but there's a compiler bug that causes +;;; it to barf if the function is a lambda form. + +#+lucid +(define-mumble-macro mumble::funcall (fn . args) + (if (and (consp fn) (eq (car fn) 'mumble::lambda)) + `(funcall ,fn ,@args) + `(funcall (the system::procedure ,fn) ,@args))) + +#+(or cmu allegro akcl lispworks mcl) +(define-mumble-macro mumble::funcall (fn . args) + `(funcall (the function ,fn) ,@args)) + +#+wcl +(define-mumble-macro mumble::funcall (fn . args) + `(funcall (the lisp:procedure ,fn) ,@args)) + +#-(or lucid cmu allegro akcl mcl lispworks wcl) +(missing-mumble-definition mumble::funcall) + + +;;; Could make this declare its fn argument too + +(define-mumble-import apply) + +(define-mumble-synonym mumble::map mapcar) +(define-mumble-synonym mumble::for-each mapc) +(define-mumble-import some) +(define-mumble-import every) +(define-mumble-import notany) +(define-mumble-import notevery) +(define-mumble-synonym mumble::procedure? functionp) + + +(define-mumble-import if) +(define-mumble-import when) +(define-mumble-import unless) + + +;;; COND and CASE differ from Common Lisp because of using "else" instead +;;; of "t" as the fall-through case. + +(define-mumble-import mumble::else) + +(define-mumble-macro mumble::cond (&rest cases) + (let ((last (car (last cases)))) + (if (eq (car last) 'mumble::else) + `(cond ,@(butlast cases) (t ,@(cdr last))) + `(cond ,@cases)))) + +(define-mumble-macro mumble::case (data &rest cases) + (let ((last (car (last cases)))) + (if (eq (car last) 'mumble::else) + `(case ,data ,@(butlast cases) (t ,@(cdr last))) + `(case ,data ,@cases)))) + + +(define-mumble-import and) +(define-mumble-import or) +(define-mumble-import not) + +(define-mumble-macro mumble::set! (variable value) + `(setq ,variable ,value)) +(define-mumble-import setf) + + +;;; AKCL's SETF brokenly tries to macroexpand the place +;;; form before looking for a define-setf-method. Redefine the +;;; internal function to do the right thing. + +#+akcl +(defun system::setf-expand-1 (place newvalue env) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method place env) + (declare (ignore access-form)) + `(let* ,(mapcar #'list + (append vars stores) + (append vals (list newvalue))) + ,store-form))) + + +;;; Allegro has renamed this stuff as per ANSI CL. + +#+allegro +(eval-when (eval compile load) + (setf (macro-function 'define-setf-method) + (macro-function 'define-setf-expander)) + (setf (symbol-function 'get-setf-method) + (symbol-function 'get-setf-expansion)) + ) + +(define-mumble-import let) +(define-mumble-import let*) + +(define-mumble-macro mumble::letrec (bindings &rest body) + `(let ,(mapcar #'car bindings) + ,@(mapcar #'(lambda (b) (cons 'setq b)) bindings) + (locally ,@body))) + +(define-mumble-import flet) +(define-mumble-import labels) + +(define-mumble-macro mumble::dynamic-let (bindings &rest body) + `(let ,bindings + (declare (special ,@(mapcar #'car bindings))) + ,@body)) + +(define-mumble-macro mumble::dynamic (name) + `(locally (declare (special ,name)) ,name)) + +(define-setf-method mumble::dynamic (name) + (let ((store (gensym))) + (values nil + nil + (list store) + `(locally (declare (special ,name)) (setf ,name ,store)) + `(locally (declare (special ,name)) ,name)))) + + +(define-mumble-macro mumble::begin (&rest body) + `(progn ,@body)) + +(define-mumble-import block) +(define-mumble-import return-from) + +(define-mumble-import do) +(define-mumble-import dolist) +(define-mumble-import dotimes) + +(define-mumble-import values) +(define-mumble-import multiple-value-bind) + +(define-mumble-macro mumble::let/cc (variable &rest body) + (let ((tagvar (gensym))) + `(let* ((,tagvar (gensym)) + (,variable (let/cc-aux ,tagvar))) + (catch ,tagvar (locally ,@body))))) + +(defun let/cc-aux (tag) + #'(lambda (&rest values) + (throw tag (values-list values)))) + + +(define-mumble-import unwind-protect) + +(define-mumble-import declare) +(define-mumble-import ignore) + + +;;; IGNORABLE is part of ANSI CL but not implemented by Lucid yet. +;;; IGNORE in Lucid seems to behave like what ANSI CL says IGNORABLE +;;; should do, but there doesn't seem to be any way to rename it. + +#+(or lucid akcl lispworks wcl) +(progn + (proclaim '(declaration mumble::ignorable)) + (define-mumble-import mumble::ignorable)) + +#+(or cmu mcl allegro) +(define-mumble-import cl:ignorable) + +#-(or lucid cmu allegro akcl mcl lispworks wcl) +(missing-mumble-definition mumble::ignorable) + + +(define-mumble-import type) + + + +;;;===================================================================== +;;; Definitions +;;;===================================================================== + + +;;; *** This shouldn't really do a DEFPARAMETER, since that proclaims +;;; *** the variable SPECIAL and makes any LETs of the variable do +;;; *** special binding rather than lexical binding. But if you just +;;; *** SETF the variable, you'll get a compiler warning about an +;;; *** undeclared free variable on every reference!!! Argggh. + +(define-mumble-macro mumble::define (pattern &rest value) + (if (consp pattern) + `(defun ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@value) + `(defparameter ,pattern ,(car value)))) + +(define-mumble-macro mumble::define-integrable (pattern &rest value) + (if (consp pattern) + `(progn + (eval-when (eval compile load) + (proclaim '(inline ,(car pattern)))) + (defun ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@value)) + `(defconstant ,pattern ,(car value)))) + + +(define-mumble-macro mumble::define-syntax (pattern . body) + `(defmacro ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@body)) + +(define-mumble-macro mumble::define-local-syntax (pattern . body) + `(eval-when (eval compile) + (defmacro ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@body))) + + +(define-mumble-macro mumble::define-setf (getter setter) + `(define-setf-method ,getter (&rest subforms) + (define-setf-aux ',setter ',getter subforms))) + +(defun define-setf-aux (setter getter subforms) + (let ((temps nil) + (tempvals nil) + (args nil) + (store (gensym))) + (dolist (x subforms) + (if (constantp x) + (push x args) + (let ((temp (gensym))) + (push temp temps) + (push x tempvals) + (push temp args)))) + (setq temps (nreverse temps)) + (setq tempvals (nreverse tempvals)) + (setq args (nreverse args)) + (values temps + tempvals + (list store) + `(,setter ,store ,@args) + `(,getter ,@args)))) + + +;;; Declaring variables special will make the compiler not proclaim +;;; about references to them. +;;; A proclamation works to disable undefined function warnings in +;;; most Lisps. Harlequin seems to offer no way to shut up these warnings. +;;; In allegro, we have to work around a bug in the compiler's handling +;;; of PROCLAIM. + +(define-mumble-macro mumble::predefine (pattern) + `(eval-when (eval compile) + #+allegro (let ((excl::*compiler-environment* nil)) + (do-predefine ',pattern)) + #-allegro (do-predefine ',pattern) + )) + +(eval-when (eval compile load) + (defun do-predefine (pattern) + (if (consp pattern) + (proclaim `(ftype (function ,(mung-decl-lambda-list (cdr pattern)) t) + ,(car pattern))) + (proclaim `(special ,pattern)))) + (defun mung-decl-lambda-list (lambda-list) + (cond ((consp lambda-list) + (cons 't (mung-decl-lambda-list (cdr lambda-list)))) + ((null lambda-list) + '()) + (t + '(&rest t)))) + ) + + +;;; CMUCL doesn't complain about function redefinitions, but Lucid does. + +#+(or cmu akcl mcl lispworks wcl) +(define-mumble-macro mumble::redefine (pattern . value) + `(mumble::define ,pattern ,@value)) + +#+lucid +(define-mumble-macro mumble::redefine (pattern . value) + `(let ((lcl:*redefinition-action* nil)) + (mumble::define ,pattern ,@value))) + +#+allegro +(define-mumble-macro mumble::redefine (pattern . value) + `(let ((excl:*redefinition-warnings* nil)) + (mumble::define ,pattern ,@value))) + +#-(or cmu lucid allegro akcl mcl lispworks wcl) +(missing-mumble-definition mumble::redefine) + + +#+(or cmu akcl mcl lispworks wcl) +(define-mumble-macro mumble::redefine-syntax (pattern . body) + `(mumble::define-syntax ,pattern ,@body)) + +#+lucid +(define-mumble-macro mumble::redefine-syntax (pattern . body) + `(eval-when (eval compile load) + (let ((lcl:*redefinition-action* nil)) + (mumble::define-syntax ,pattern ,@body)))) + +#+allegro +(define-mumble-macro mumble::redefine-syntax (pattern . body) + `(eval-when (eval compile load) + (let ((excl:*redefinition-warnings* nil)) + (mumble::define-syntax ,pattern ,@body)))) + +#-(or cmu lucid allegro akcl mcl lispworks wcl) +(missing-mumble-definition mumble::redefine-syntax) + + + +;;;===================================================================== +;;; Equivalence +;;;===================================================================== + +(define-mumble-function-inline mumble::eq? (x y) + (eq x y)) +(define-mumble-function-inline mumble::eqv? (x y) + (eql x y)) + +(define-mumble-function mumble::equal? (x1 x2) + (cond ((eql x1 x2) + t) + ((consp x1) + (and (consp x2) + (mumble::equal? (car x1) (car x2)) + (mumble::equal? (cdr x1) (cdr x2)))) + ((simple-string-p x1) + (and (simple-string-p x2) + (string= x1 x2))) + ((simple-vector-p x1) + (and (simple-vector-p x2) + (eql (length (the simple-vector x1)) + (length (the simple-vector x2))) + (every #'mumble::equal? + (the simple-vector x1) + (the simple-vector x2)))) + (t nil))) + + +;;;===================================================================== +;;; Lists +;;;===================================================================== + +(define-mumble-function-inline mumble::pair? (x) + (consp x)) + +(define-mumble-import cons) + + +;;; Can't import this directly because of type problems. + +(define-mumble-synonym mumble::list list) + +(define-mumble-function-inline mumble::make-list (length &optional (init nil)) + (the list + (make-list length :initial-element init))) + +(define-mumble-import car) +(define-mumble-import cdr) +(define-mumble-import caar) +(define-mumble-import cadr) +(define-mumble-import cadr) +(define-mumble-import cddr) +(define-mumble-import caaar) +(define-mumble-import caadr) +(define-mumble-import caadr) +(define-mumble-import caddr) +(define-mumble-import cdaar) +(define-mumble-import cdadr) +(define-mumble-import cdadr) +(define-mumble-import cdddr) +(define-mumble-import caaaar) +(define-mumble-import caaadr) +(define-mumble-import caaadr) +(define-mumble-import caaddr) +(define-mumble-import cadaar) +(define-mumble-import cadadr) +(define-mumble-import cadadr) +(define-mumble-import cadddr) +(define-mumble-import cdaaar) +(define-mumble-import cdaadr) +(define-mumble-import cdaadr) +(define-mumble-import cdaddr) +(define-mumble-import cddaar) +(define-mumble-import cddadr) +(define-mumble-import cddadr) +(define-mumble-import cddddr) + +(define-mumble-function-inline mumble::null? (x) + (null x)) + +(define-mumble-function mumble::list? (x) + (cond ((null x) t) + ((consp x) (mumble::list? (cdr x))) + (t nil))) + +(define-mumble-function-inline mumble::length (x) + (the fixnum (length (the list x)))) + +(define-mumble-import append) +(define-mumble-import nconc) + +(define-mumble-function-inline mumble::reverse (x) + (the list (reverse (the list x)))) +(define-mumble-function-inline mumble::nreverse (x) + (the list (nreverse (the list x)))) + +(define-mumble-function-inline mumble::list-tail (list n) + (nthcdr n list)) +(define-mumble-function-inline mumble::list-ref (list n) + (nth n list)) + +(define-mumble-import last) +(define-mumble-import butlast) + +(define-setf-method mumble::list-ref (list n) + (get-setf-method `(nth ,n ,list))) + +(define-mumble-function-inline mumble::memq (object list) + (member object list :test #'eq)) +(define-mumble-function-inline mumble::memv (object list) + (member object list)) +(define-mumble-function-inline mumble::member (object list) + (member object list :test #'mumble::equal?)) + +;;; *** The Lucid compiler is not doing anything inline for assq so +;;; *** I'm rewriting this -- jcp +(define-mumble-function mumble::assq (object list) + (if (null list) + nil + (if (eq object (caar list)) + (car list) + (mumble::assq object (cdr list))))) + +(define-mumble-function-inline mumble::assv (object list) + (assoc object list)) +(define-mumble-function-inline mumble::assoc (object list) + (assoc object list :test #'mumble::equal?)) + +(define-mumble-import push) +(define-mumble-import pop) + +(define-mumble-synonym mumble::list-copy copy-list) + + +;;;===================================================================== +;;; Symbols +;;;===================================================================== + +(define-mumble-function-inline mumble::symbol? (x) + (symbolp x)) +(define-mumble-synonym mumble::symbol->string symbol-name) + +(define-mumble-function-inline mumble::string->symbol (x) + (intern x)) + + +;;; We want a gensym that follows the new ANSI CL gensym-name-stickiness +;;; decision. + +#+(or lucid akcl wcl) +(define-mumble-function mumble::gensym (&optional (prefix "G")) + (gensym prefix)) + +#+(or cmu allegro mcl lispworks) +(define-mumble-import gensym) + +#-(or lucid akcl wcl cmu allegro mcl lispworks) +(missing-mumble-definition mumble::gensym) + +(define-mumble-function mumble::gensym? (x) + (and (symbolp x) + (not (symbol-package x)))) + +(defun symbol-append (&rest symbols) + (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) +(define-mumble-import symbol-append) + + +;;;===================================================================== +;;; Characters +;;;===================================================================== + +(define-mumble-function-inline mumble::char? (x) + (characterp x)) + +(define-mumble-synonym mumble::char=? char=) +(define-mumble-synonym mumble::char? char>) +(define-mumble-synonym mumble::char>=? char>=) +(define-mumble-synonym mumble::char<=? char<=) + +(define-mumble-synonym mumble::char-ci=? char-equal) +(define-mumble-synonym mumble::char-ci? char-greaterp) +(define-mumble-synonym mumble::char-ci>=? char-not-lessp) +(define-mumble-synonym mumble::char-ci<=? char-not-greaterp) + +(define-mumble-synonym mumble::char-alphabetic? alpha-char-p) +(define-mumble-synonym mumble::char-numeric? digit-char-p) + +(define-mumble-function mumble::char-whitespace? (c) + (member c '(#\space #\tab #\newline #\linefeed #\page #\return))) + +(define-mumble-synonym mumble::char-upper-case? upper-case-p) +(define-mumble-synonym mumble::char-lower-case? lower-case-p) + +(define-mumble-synonym mumble::char->integer char-code) +(define-mumble-synonym mumble::integer->char code-char) + +(define-mumble-import char-upcase) +(define-mumble-import char-downcase) +(define-mumble-import char-name) + +(define-mumble-synonym mumble::char->digit digit-char-p) + + +;;;===================================================================== +;;; Strings +;;;===================================================================== + +(define-mumble-function-inline mumble::string? (x) + (simple-string-p x)) + +(define-mumble-function-inline mumble::make-string + (length &optional (init nil init-p)) + (the simple-string + (if init-p + (make-string length :initial-element init) + (make-string length)))) + +(define-mumble-function-inline mumble::string (char &rest more-chars) + (the simple-string (coerce (cons char more-chars) 'string))) + +(define-mumble-function-inline mumble::string-length (string) + (the fixnum (length (the simple-string string)))) + +(define-mumble-function-inline mumble::string-ref (x n) + (the character (schar (the simple-string x) (the fixnum n)))) + +(define-setf-method mumble::string-ref (string n) + (get-setf-method `(schar ,string ,n))) + +(define-mumble-synonym mumble::string=? string=) +(define-mumble-synonym mumble::string? string>) +(define-mumble-synonym mumble::string<=? string<=) +(define-mumble-synonym mumble::string>=? string>=) + +(define-mumble-synonym mumble::string-ci=? string-equal) +(define-mumble-synonym mumble::string-ci? string-greaterp) +(define-mumble-synonym mumble::string-ci<=? string-not-greaterp) +(define-mumble-synonym mumble::string-ci>=? string-not-lessp) + +(define-mumble-function-inline mumble::substring (string start end) + (the simple-string (subseq (the simple-string string) start end))) + +(define-mumble-function-inline mumble::string-append + (string &rest more-strings) + (declare (type simple-string string)) + (the simple-string (apply #'concatenate 'string string more-strings))) + +(define-mumble-function-inline mumble::string->list (string) + (the list (coerce (the simple-string string) 'list))) + +(define-mumble-function-inline mumble::list->string (list) + (the simple-string (coerce (the list list) 'string))) + +(define-mumble-function-inline mumble::string-copy (string) + (the simple-string (copy-seq (the simple-string string)))) + +(define-mumble-import string-upcase) +(define-mumble-import string-downcase) + + +;;;===================================================================== +;;; Vectors +;;;===================================================================== + +(define-mumble-function-inline mumble::vector? (x) + (simple-vector-p x)) + +(define-mumble-function-inline mumble::make-vector + (length &optional (init nil init-p)) + (declare (type fixnum length)) + (the simple-vector + (if init-p + (make-array length :initial-element init) + (make-array length)))) + + +;;; Can't import directly because types are incompatible. + +(define-mumble-synonym mumble::vector vector) + +(define-mumble-function-inline mumble::vector-length (vector) + (the fixnum (length (the simple-vector vector)))) + +(define-mumble-function-inline mumble::vector-ref (x n) + (svref (the simple-vector x) (the fixnum n))) + +(define-setf-method mumble::vector-ref (vector n) + (get-setf-method `(svref ,vector ,n))) + +(define-mumble-function-inline mumble::vector->list (vector) + (the list (coerce (the simple-vector vector) 'list))) + +(define-mumble-function-inline mumble::list->vector (list) + (the simple-vector (coerce (the list list) 'simple-vector))) + +(define-mumble-function-inline mumble::vector-copy (vector) + (the simple-vector (copy-seq (the simple-vector vector)))) + + +;;;===================================================================== +;;; Numbers +;;;===================================================================== + +(define-mumble-synonym mumble::number? numberp) +(define-mumble-synonym mumble::integer? integerp) +(define-mumble-synonym mumble::rational? rationalp) +(define-mumble-synonym mumble::float? floatp) + +(define-mumble-function-inline mumble::fixnum? (x) + (typep x 'fixnum)) + +(define-mumble-synonym mumble::exact->inexact float) + +(define-mumble-import =) +(define-mumble-import <) +(define-mumble-import >) +(define-mumble-import <=) +(define-mumble-import >=) + +(define-mumble-synonym mumble::zero? zerop) +(define-mumble-function-inline mumble::positive? (x) + (> x 0)) +(define-mumble-function-inline mumble::negative? (x) + (< x 0)) + +(define-mumble-import min) +(define-mumble-import max) + +(define-mumble-import +) +(define-mumble-import *) +(define-mumble-import -) +(define-mumble-import /) + +(define-mumble-synonym mumble::quotient floor) +(define-mumble-synonym mumble::remainder rem) +(define-mumble-synonym mumble::modulo mod) + +(define-mumble-function-inline mumble::floor (x) + (if (floatp x) (ffloor x) (floor (the rational x)))) +(define-mumble-function-inline mumble::ceiling (x) + (if (floatp x) (fceiling x) (ceiling (the rational x)))) +(define-mumble-function-inline mumble::truncate (x) + (if (floatp x) (ftruncate x) (truncate (the rational x)))) +(define-mumble-function-inline mumble::round (x) + (if (floatp x) (fround x) (round (the rational x)))) + +(define-mumble-synonym mumble::floor->exact floor) +(define-mumble-synonym mumble::ceiling->exact ceiling) +(define-mumble-synonym mumble::truncate->exact truncate) +(define-mumble-synonym mumble::round->exact round) + +(define-mumble-import 1+) +(define-mumble-import 1-) +(define-mumble-import incf) +(define-mumble-import decf) + +(define-mumble-function mumble::number->string (number &optional (radix 10)) + (let ((*print-base* radix)) + (prin1-to-string number))) + +(define-mumble-function mumble::string->number (string &optional (radix 10)) + (let ((*read-base* radix)) + (read-from-string string))) + +(define-mumble-import expt) + + + +;;;===================================================================== +;;; Tables +;;;===================================================================== + +(define-mumble-synonym mumble::table? hash-table-p) + +(define-mumble-function-inline mumble::make-table () + (make-hash-table :test #'eq)) + +(define-mumble-function-inline mumble::table-entry (table key) + (gethash key table)) + +(define-setf-method mumble::table-entry (table key) + (get-setf-method `(gethash ,key ,table))) + +(define-mumble-synonym mumble::table-for-each maphash) + +(define-mumble-function mumble::copy-table (old-table) + (let ((new-table (make-hash-table :test #'eq + :size (1+ (hash-table-count old-table))))) + (maphash #'(lambda (key val) (setf (gethash key new-table) val)) + old-table) + new-table)) + + +;;;===================================================================== +;;; I/O +;;;===================================================================== + +(define-mumble-function-inline mumble::call-with-input-file (string proc) + (with-open-file (stream (expand-filename string) :direction :input) + (funcall (the function proc) stream))) + +(define-mumble-function-inline mumble::call-with-output-file (string proc) + (with-open-file (stream (expand-filename string) + :direction :output :if-exists :new-version) + (funcall (the function proc) stream))) + +(define-mumble-function-inline mumble::call-with-input-string (string proc) + (with-input-from-string (stream string) + (funcall (the function proc) stream))) + +(define-mumble-function-inline mumble::call-with-output-string (proc) + (with-output-to-string (stream) + (funcall (the function proc) stream))) + +(define-mumble-synonym mumble::input-port? input-stream-p) +(define-mumble-synonym mumble::output-port? output-stream-p) + +(define-mumble-function-inline mumble::current-input-port () + *standard-input*) +(define-mumble-function-inline mumble::current-output-port () + *standard-output*) + +(define-mumble-function-inline mumble::open-input-file (string) + (open (expand-filename string) :direction :input)) + +(define-mumble-function-inline mumble::open-output-file (string) + (open (expand-filename string) :direction :output :if-exists :new-version)) + + +(define-mumble-synonym mumble::close-input-port close) +(define-mumble-synonym mumble::close-output-port close) + +(defvar *eof-object* (make-symbol "EOF")) + +(define-mumble-function-inline mumble::read + (&optional (port *standard-input*)) + (read port nil *eof-object*)) + +(define-mumble-function-inline mumble::read-char + (&optional (port *standard-input*)) + (read-char port nil *eof-object*)) + +(define-mumble-function-inline mumble::peek-char + (&optional (port *standard-input*)) + (peek-char nil port nil *eof-object*)) + +(define-mumble-function-inline mumble::read-line + (&optional (port *standard-input*)) + (read-line port nil *eof-object*)) + +(define-mumble-function-inline mumble::eof-object? (x) + (eq x *eof-object*)) + + +;;;===================================================================== +;;; Printer +;;;===================================================================== + +(define-mumble-function mumble::internal-write (object port) + (write object :stream port)) +(define-mumble-function-inline mumble::internal-output-width (port) + (declare (ignore port)) + nil) +(define-mumble-function-inline mumble::internal-output-position (port) + (declare (ignore port)) + nil) +(define-mumble-synonym mumble::internal-write-char write-char) +(define-mumble-function-inline mumble::internal-write-string + (string port start end) + (write-string string port :start start :end end)) +(define-mumble-synonym mumble::internal-newline terpri) +(define-mumble-synonym mumble::internal-fresh-line fresh-line) +(define-mumble-synonym mumble::internal-finish-output finish-output) +(define-mumble-synonym mumble::internal-force-output force-output) +(define-mumble-synonym mumble::internal-clear-output clear-output) + +(define-mumble-function mumble::internal-write-to-string (object) + (write-to-string object)) + + +(define-mumble-function-inline mumble::internal-warning (string) + (warn "~a" string)) + +(define-mumble-function-inline mumble::internal-error (string) + (error "~a" string)) + + +;;; Printer stuff used directly by the pretty printer + +(define-mumble-import *print-escape*) +(define-mumble-import *print-circle*) +(define-mumble-import *print-pretty*) +(define-mumble-import *print-level*) +(define-mumble-import *print-length*) +(define-mumble-import *print-base*) +(define-mumble-import *print-radix*) + + +;;; These functions and variables are all defined with the XP stuff. But, +;;; let's export all the symbols from the mumble package. + +(define-mumble-import mumble::write) +(define-mumble-import mumble::print) +(define-mumble-import mumble::prin1) +(define-mumble-import mumble::princ) +(define-mumble-import mumble::pprint) +(define-mumble-import mumble::prin1-to-string) +(define-mumble-import mumble::princ-to-string) +(define-mumble-import mumble::write-char) +(define-mumble-import mumble::write-string) +(define-mumble-import mumble::write-line) +(define-mumble-import mumble::terpri) +(define-mumble-import mumble::fresh-line) +(define-mumble-import mumble::finish-output) +(define-mumble-import mumble::force-output) +(define-mumble-import mumble::clear-output) +(define-mumble-import mumble::display) +(define-mumble-import mumble::newline) +(define-mumble-import mumble::*print-shared*) +(define-mumble-import mumble::*print-dispatch*) +(define-mumble-import mumble::*print-right-margin*) +(define-mumble-import mumble::*print-miser-width*) +(define-mumble-import mumble::*print-lines*) +(define-mumble-import mumble::*default-right-margin*) +(define-mumble-import mumble::*last-abbreviated-printing*) +(define-mumble-import mumble::*print-structure*) +(define-mumble-import mumble::*print-structure-slots*) +(define-mumble-import mumble::standard-print-dispatch) +(define-mumble-import mumble::pprint-newline) +(define-mumble-import mumble::pprint-logical-block) +(define-mumble-import mumble::pprint-pop) +(define-mumble-import mumble::pprint-exit-if-list-exhausted) +(define-mumble-import mumble::pprint-indent) +(define-mumble-import mumble::pprint-tab) +(define-mumble-import mumble::pprint-fill) +(define-mumble-import mumble::pprint-linear) +(define-mumble-import mumble::pprint-tabular) +(define-mumble-import mumble::format) +(define-mumble-import mumble::warning) +(define-mumble-import mumble::error) + + +;;; These are keywords for pprint-newline. + +(define-mumble-import mumble::linear) +(define-mumble-import mumble::fill) +(define-mumble-import mumble::miser) +(define-mumble-import mumble::mandatory) + +;;; These are keywords for pprint-indent + +;; (define-mumble-import mumble::block) ; already imported as special form +(define-mumble-import mumble::current) + +;;; These are keywords for pprint-tab + +(define-mumble-import mumble::line) +(define-mumble-import mumble::section) +(define-mumble-import mumble::line-relative) +(define-mumble-import mumble::section-relative) + + +;;;===================================================================== +;;; System Interface +;;;===================================================================== + +(define-mumble-import macroexpand-1) +(define-mumble-import macroexpand) + + +;;; WITH-COMPILATION-UNIT is an ANSI CL feature that isn't yet +;;; supported by all Lisps. + +#+lucid +(define-mumble-macro mumble::with-compilation-unit (options &body body) + (declare (ignore options)) + `(lcl:with-deferred-warnings ,@body)) + +#+(or cmu mcl allegro lispworks) +(define-mumble-import with-compilation-unit) + +#+(or akcl wcl) +(define-mumble-macro mumble::with-compilation-unit (options &body body) + (declare (ignore options)) + `(progn ,@body)) + +#-(or lucid allegro cmu akcl mcl lispworks wcl) +(missing-mumble-definition mumble::with-compilation-unit) + + +(define-mumble-function mumble::eval (form &optional compile-p) + (if compile-p + (mumble::with-compilation-unit () + (eval-compiling-functions form)) + (eval form))) + + +;;; Simply doing (funcall (compile nil `(lambda () ,form))) would work +;;; except that top-level-ness actions would be lost (causing extraneous +;;; warning messages about global variables whose references are compiled +;;; before a previous predefine is executed, etc). So make an attempt +;;; to process nested top-level forms in order. This doesn't look for +;;; all of the common-lispy things that might show up in macro expansions, +;;; but it's close enough. + +(defun eval-compiling-functions (form) + (if (atom form) + (eval form) + (let ((fn (car form))) + (cond ((or (eq fn 'mumble::begin) + (eq fn 'progn)) + (do ((forms (cdr form) (cdr forms))) + ((null (cdr forms)) (eval-compiling-functions (car forms))) + (eval-compiling-functions (car forms)))) + ((eq fn 'mumble::define) + (if (consp (cadr form)) + (compile-define form) + (compile-other form))) + ((eq fn 'mumble::define-integrable) + (if (consp (cadr form)) + (progn + (proclaim `(inline ,(car (cadr form)))) + (compile-define form)) + (compile-other form))) + ((eq fn 'mumble::predefine) + (do-predefine (cadr form))) + ((macro-function fn) + (eval-compiling-functions (macroexpand-1 form))) + (t + (compile-other form)))))) + +(defun compile-define (form) + (let ((name (car (cadr form))) + (args (mung-lambda-list (cdr (cadr form)))) + (body (cddr form))) + (compile name `(lambda ,args ,@body)) + name)) + +(defun compile-other (form) + (funcall (compile nil `(lambda () ,form)))) + + +;;; Load and compile-file aren't directly imported from the host +;;; Common Lisp because we want to do our own defaulting of file +;;; name extensions. + +(define-mumble-function mumble::load (filename) + (setq filename (expand-filename filename)) + (if (string= (mumble::filename-type filename) "") + (let ((source-file (build-source-filename filename)) + (binary-file (build-binary-filename filename))) + (if (and (probe-file binary-file) + (> (file-write-date binary-file) + (file-write-date source-file))) + (load binary-file) + (load source-file))) + (load filename))) + + +;;; This is used to control OPTIMIZE declarations in a somewhat more +;;; portable way -- different implementations may need slightly different +;;; combinations. +;;; 0 = do as little as possible when compiling code +;;; 1 = use "default" compiler settings +;;; 2 = omit safety checks and do "easy" speed optimizations. +;;; 3 = do as much as possible; type inference, inlining, etc. May be slow. +;;; #f = don't mess with optimize settings. + +(defvar *code-quality* nil) +(define-mumble-import *code-quality*) + +(defun code-quality-hack (q) + (cond ((eql q 0) + (proclaim '(optimize (speed 1) (safety 3) (compilation-speed 3) + #+cmu (ext:debug 1) + #+(or mcl allegro lispworks) (debug 1) + ))) + ((eql q 1) + (proclaim '(optimize (speed 1) (safety 1) (compilation-speed 3) + #+cmu (ext:debug 1) + #+(or mcl allegro lispworks) (debug 1) + ))) + ((eql q 2) + (proclaim '(optimize (speed 3) (safety 0) (compilation-speed 3) + #+cmu (ext:debug 0) + #+(or mcl allegro lispworks) (debug 0) + ))) + ((eql q 3) + (proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0) + #+cmu (ext:debug 0) + #+(or mcl allegro lispworks) (debug 0) + ))) + (t + (warn "Bogus *code-quality* setting ~s." q)))) + + +;;; If we don't do this, code generated with high code-quality settings +;;; can't be interrupted with ^C. + +#+allegro +(setf compiler:generate-interrupt-checks-switch + #'(lambda (safety space speed debug) + (declare (ignore safety space speed debug)) + t)) + + +;;; Note that we expect the binary filename (if supplied) to be +;;; relative to the current directory, not to the source filename. +;;; Lucid and AKCL (and maybe other implementations) merge the :output-file +;;; pathname with the source filename, but the merge by expand-filename +;;; should prevent it from doing anything. + +(define-mumble-function mumble::compile-file (filename &optional binary) + (if *code-quality* (code-quality-hack *code-quality*)) + (setq filename (expand-filename filename)) + (if (string= (mumble::filename-type filename) "") + (setq filename (build-source-filename filename))) + (if binary + (compile-file filename :output-file (expand-filename binary)) + (compile-file filename))) + + +;;; See cl-init.lisp for initialization of *lisp-binary-file-type*. + +(defconstant source-file-type ".scm") +(defconstant binary-file-type *lisp-binary-file-type*) +(define-mumble-import source-file-type) +(define-mumble-import binary-file-type) + + +(defun build-source-filename (filename) + (mumble::assemble-filename filename filename source-file-type)) + +(defun build-binary-filename (filename) + (mumble::assemble-filename filename filename binary-file-type)) + +(proclaim '(ftype (function (simple-string) simple-string) + mumble::filename-place + mumble::filename-name + mumble::filename-type + expand-filename)) + +(proclaim '(ftype (function (simple-string simple-string simple-string) + simple-string) + mumble::assemble-filename)) + +(define-mumble-function mumble::assemble-filename (place name type) + (concatenate 'string + (mumble::filename-place place) + (mumble::filename-name name) + (mumble::filename-type type))) + +(define-mumble-function mumble::filename-place (filename) + (declare (simple-string filename)) + (let ((slash (position #\/ filename :from-end t))) + (if slash + (subseq filename 0 (1+ slash)) + ""))) + +(define-mumble-function mumble::filename-name (filename) + (declare (simple-string filename)) + (let* ((slash (position #\/ filename :from-end t)) + (beg (if slash (1+ slash) 0)) + (dot (position #\. filename :start beg))) + (if (or slash dot) + (subseq filename beg (or dot (length filename))) + filename))) + +(define-mumble-function mumble::filename-type (filename) + (declare (simple-string filename)) + (let* ((slash (position #\/ filename :from-end t)) + (beg (if slash (1+ slash) 0)) + (dot (position #\. filename :start beg))) + (if dot + (subseq filename dot (length filename)) + ""))) + + +;;; This function is called by all functions that pass filenames down +;;; to the operating system. It does environment variable substitution +;;; and merging with *default-pathname-defaults* (set by the cd function). +;;; Since this function translates mumble's notion of pathnames into +;;; a lower-level representation, this function should never need to +;;; be called outside of this file. + +(defun expand-filename (filename) + (declare (simple-string filename)) + (namestring + (merge-pathnames + (fix-filename-syntax + (if (eql (schar filename 0) #\$) + (let* ((end (length filename)) + (slash (or (position #\/ filename) end)) + (new (mumble::getenv (subseq filename 1 slash)))) + (if new + (concatenate 'string new (subseq filename slash end)) + filename)) + filename) + )))) + + +;;; On non-unix machines, may need to change the mumble unix-like filename +;;; syntax to whatever the normal syntax used by the implementation is. + +#+mcl +(defun fix-filename-syntax (filename) + (substitute #\: #\/ filename)) + +#-mcl +(defun fix-filename-syntax (filename) + filename) + + +;;; AKCL's compile-file merges the output pathname against the input +;;; pathname. If the output pathname doesn't have an explicit directory +;;; but the input pathname does, the wrong thing will happen. This +;;; hack is so that expand-filename will always put a directory +;;; specification on both pathnames. +;;; Lucid CL does similar merging, but *default-pathname-defaults* +;;; already defaults to the truename of the current directory. + +#+akcl +(setf *default-pathname-defaults* (truename "./")) + + +;;; WCL's *default-pathname-defaults* is OK except that it has a +;;; type of .lisp, which is inappropriate. + +#+wcl +(setf *default-pathname-defaults* + (make-pathname :directory + (pathname-directory *default-pathname-defaults*))) + +#+(or mcl lispworks) +(setf *default-pathname-defaults* + (truename *default-pathname-defaults*)) + + +(define-mumble-function mumble::file-exists? (filename) + (probe-file (expand-filename filename))) + +(define-mumble-function mumble::file-write-date (filename) + (file-write-date (expand-filename filename))) + +(define-mumble-synonym mumble::current-date get-universal-time) + +(define-mumble-function mumble::get-run-time () + (/ (get-internal-run-time) (float internal-time-units-per-second))) + + +;;; Get environment variables + +#+lucid +(progn + (mumble::predefine (mumble::getenv string)) + (define-mumble-synonym mumble::getenv lcl:environment-variable)) + +#+cmu +(define-mumble-function mumble::getenv (string) + (let ((symbol (intern string (find-package "KEYWORD")))) + (cdr (assoc symbol extensions:*environment-list*)))) + +#+(or akcl allegro lispworks) +(define-mumble-function mumble::getenv (string) + (system::getenv string)) + +#+wcl +(define-mumble-function mumble::getenv (string) + (lisp:getenv string)) + + +;;; Hmmm. The Mac doesn't have environment variables, so we'll have to +;;; roll our own. + +#+mcl +(progn + (defvar *environment-alist* '()) + (define-mumble-function mumble::getenv (string) + (cdr (assoc string *environment-alist* :test #'string=))) + ) + + +#-(or lucid allegro cmu akcl mcl lispworks wcl) +(missing-mumble-definition mumble::getenv) + + +;;; Change working directory. +;;; This stores a directory pathname in *default-pathname-defaults*. +;;; See also expand-filename. + +(define-mumble-function mumble::cd (filename) + (if (not (eql (schar filename (1- (length filename))) #\/)) + (setq filename (concatenate 'string filename "/"))) + (setq *default-pathname-defaults* (pathname (expand-filename filename)))) + + +;;; Leave Lisp + +#+lucid +(define-mumble-synonym mumble::exit lcl:quit) + +#+allegro +(define-mumble-synonym mumble::exit excl:exit) + +#+cmu +(define-mumble-synonym mumble::exit extensions:quit) + +#+akcl +(define-mumble-synonym mumble::exit lisp:bye) + +#+mcl +(define-mumble-synonym mumble::exit ccl:quit) + +#+lispworks +(define-mumble-synonym mumble::exit lw:bye) + +#+wcl +(define-mumble-synonym mumble::exit lisp:quit) + + +#-(or lucid allegro cmu akcl mcl lispworks wcl) +(missing-mumble-definition mumble::exit) + + + +;;;===================================================================== +;;; Reader support +;;;===================================================================== + + +;;; Make the default readtable recognize #f and #t. +;;; CMUCL's loader rebinds *readtable* when loading file, so can't +;;; setq it here; hack the default readtable instead. + +#+(or cmu mcl allegro lispworks) +(defparameter *mumble-readtable* *readtable*) + +#+(or lucid akcl wcl) +(progn + (defparameter *mumble-readtable* (copy-readtable nil)) + (setq *readtable* *mumble-readtable*) + ) + +#-(or lucid allegro cmu akcl mcl lispworks wcl) +(missing-mumble-definition *mumble-readtable*) + + +;;; Lucid's debugger uses the standard readtable rather than *readtable* +;;; unless you do this magic trick. + +#+lucid +(sys:add-debugger-binding '*readtable* *mumble-readtable*) + + + +(set-dispatch-macro-character #\# #\f + #'(lambda (stream subchar arg) + (declare (ignore stream subchar arg)) + nil)) + +(set-dispatch-macro-character #\# #\t + #'(lambda (stream subchar arg) + (declare (ignore stream subchar arg)) + t)) + + + +;;;===================================================================== +;;; Random stuff +;;;===================================================================== + +(defconstant mumble::lisp-implementation-name *lisp-implementation-name*) +(define-mumble-import mumble::lisp-implementation-name) + +(define-mumble-function mumble::identify-system () + (format nil "~a version ~a on ~a" + (or (lisp-implementation-type) + "Generic Common Lisp") + (or (lisp-implementation-version) + "Generic") + (or (machine-type) + "Generic Machine"))) + +(defconstant mumble::left-to-right-evaluation t) +(define-mumble-import mumble::left-to-right-evaluation) + + +#+excl +(define-mumble-function mumble::gc-messages (onoff) + (setf (sys:gsgc-switch :print) onoff)) +#+cmu +(define-mumble-function mumble::gc-messages (onoff) + (setf extensions:*gc-verbose* onoff)) +#+(or lispworks akcl wcl mcl) +(define-mumble-function mumble::gc-messages (onoff) + onoff) ; can't figure out if they have a hook or not +#+lucid +(define-mumble-function mumble::gc-messages (onoff) + (setf lcl:*gc-silence* (not onoff)) + onoff) + + +#-(or lucid cmu allegro akcl mcl lispworks wcl) +(missing-mumble-definition mumble::gc-messages) + + +(define-mumble-import identity) diff --git a/cl-support/cl-init.lisp b/cl-support/cl-init.lisp new file mode 100644 index 0000000..4d78cde --- /dev/null +++ b/cl-support/cl-init.lisp @@ -0,0 +1,170 @@ +;;; cl-init.lisp -- initialize Common Lisp, loading cl-specific files. +;;; +;;; author : Sandra Loosemore +;;; date : 23 Oct 1991 +;;; +;;; All of the files loaded here are assumed to be regular Common Lisp +;;; files. + +(in-package "MUMBLE-IMPLEMENTATION") + + +;;; Turn off bogus warnings and messages!!! + +;;; Lucid complains if files don't start with IN-PACKAGE. +#+lucid +(setq lcl:*warn-if-no-in-package* '()) + + +;;; CMU CL prints too many compiler progress messages. +#+cmu +(progn + (setq *compile-print* '()) + (setq *load-verbose* t) + ) + + +;;; AKCL complains if any package operations appear at top-level +;;; after any other code. +;;; Also prints useless notes about when it does tail recursion elimination. +#+akcl +(progn + (setq compiler:*suppress-compiler-notes* t) + (setq compiler:*compile-verbose* t) + (setq *load-verbose* t) + (setq compiler::*compile-ordinaries* t) + (si:putprop 'make-package nil 'compiler::package-operation) + (si:putprop 'shadow nil 'compiler::package-operation) + (si:putprop 'shadowing-import nil 'compiler::package-operation) + (si:putprop 'export nil 'compiler::package-operation) + (si:putprop 'unexport nil 'compiler::package-operation) + (si:putprop 'use-package nil 'compiler::package-operation) + (si:putprop 'unuse-package nil 'compiler::package-operation) + (si:putprop 'import nil 'compiler::package-operation) + (si:putprop 'provide nil 'compiler::package-operation) + (si:putprop 'require nil 'compiler::package-operation) + ) + + +;;; Allegro also issues too many messages. +;;; ***We really ought to rename the defstructs that give the package +;;; locked errors.... + +#+allegro +(progn + (setf *compile-print* nil) + (setf compiler:*cltl1-compile-file-toplevel-compatibility-p* nil) + (setq excl:*enable-package-locked-errors* nil) + (setf excl:*load-source-file-info* nil) + (setf excl:*record-source-file-info* nil) + (setf excl:*load-xref-info* nil) + (setf excl:*record-source-file-info* nil) + ) + + +;;; Harlequin Lispworks prints too many messages too. + +#+lispworks +(progn + (setf *compile-print* nil) + (setf *load-print* nil) + (lw:toggle-source-debugging nil) + ) + + +;;; Load up definitions + +(defvar *lisp-source-file-type* ".lisp") +(defvar *lisp-binary-file-type* + #+lucid + (namestring (make-pathname :type (car lcl:*load-binary-pathname-types*))) + #+allegro + (concatenate 'string "." excl:*fasl-default-type*) + #+cmu + (concatenate 'string "." (c:backend-fasl-file-type c:*backend*)) + #+akcl + ".o" + #+mcl + ".fasl" + #+lispworks + ".wfasl" + #+wcl + ".o" + #-(or lucid allegro cmu akcl mcl lispworks wcl) + (error "Don't know how to initialize *LISP-BINARY-FILE-TYPE*.") + ) + +(defvar *lisp-implementation-name* + #+lucid "lucid" + #+(and allegro next) "allegro-next" + #+(and allegro (not next)) "allegro" + #+cmu "cmu" + #+akcl "akcl" + #+mcl "mcl" + #+lispworks "lispworks" + #+wcl "wcl" + #-(or lucid allegro cmu akcl mcl lispworks wcl) + (error "Don't know how to initialize *LISP-IMPLEMENTATION-NAME*.") + ) + + + + +;;; Note that this assumes that the current directory is $Y2. +;;; Environment variables in pathnames may not be supported by the +;;; host Lisp. + +#-mcl (progn + (defvar *support-directory* "cl-support/") + (defvar *support-binary-directory* + (concatenate 'string + *support-directory* + *lisp-implementation-name* + "/"))) + +(defun load-compiled-cl-file (filename) + (let ((source-file (concatenate 'string + *support-directory* + filename + *lisp-source-file-type*)) + (binary-file (concatenate 'string + *support-binary-directory* + filename + *lisp-binary-file-type*))) + (if (or (not (probe-file binary-file)) + (< (file-write-date binary-file) (file-write-date source-file))) + (compile-file source-file :output-file (merge-pathnames binary-file))) + (load binary-file))) + + +;;; Do NOT change the load order of these files. + +(load-compiled-cl-file "cl-setup") +(load-compiled-cl-file "cl-support") +(load-compiled-cl-file "cl-definitions") +(load-compiled-cl-file "cl-types") +(load-compiled-cl-file "cl-structs") + + +;;; It would be nice if at this point we could switch *package* +;;; over to the right package. But because *package* is rebound while +;;; this file is being loaded, it will get set back to whatever it was +;;; anyway. Bummer. Well, let's at least make the package that we want +;;; to use. + +(make-package "MUMBLE-USER" :use '("MUMBLE")) + + +;;; Compile and load the rest of the system. (The Lucid compiler is fast +;;; enough to make it practical to compile things all the time.) + +(eval-when (eval compile load) + (setf *package* (find-package "MUMBLE-USER"))) + +(load "$Y2/support/system") +(compile-haskell) + + +;;; All done + +(write-line "Remember to do (in-package \"MUMBLE-USER\")!") diff --git a/cl-support/cl-setup.lisp b/cl-support/cl-setup.lisp new file mode 100644 index 0000000..361963c --- /dev/null +++ b/cl-support/cl-setup.lisp @@ -0,0 +1,30 @@ +;;; cl-setup.lisp -- set up mumble environment in Common Lisp +;;; +;;; author : Sandra Loosemore +;;; date : 10 Oct 1991 +;;; +;;; This file must be loaded before either compiling or loading +;;; the cl-definitions file. + + +;;; The mumble package exports only those symbols that have definitions +;;; in mumble. Many of these symbols shadow built-in CL definitions. +;;; Programs that use mumble should use the mumble package in place of +;;; (rather than in addition to) the CL package. + +(unless (find-package "MUMBLE") + (make-package "MUMBLE" :use nil)) + + +;;; The actual implementation of the mumble compatibility library happens +;;; in the MUMBLE-IMPLEMENTATION package. We'll explicitly package-qualify +;;; all symbols from the MUMBLE package that it references, and rely +;;; on the definitional macros to arrange to export them from the MUMBLE +;;; package. + +(unless (find-package "MUMBLE-IMPLEMENTATION") + (make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))) + + + + diff --git a/cl-support/cl-structs.lisp b/cl-support/cl-structs.lisp new file mode 100644 index 0000000..0d57693 --- /dev/null +++ b/cl-support/cl-structs.lisp @@ -0,0 +1,699 @@ +;;; cl-structs.lisp -- extended structure definitions +;;; +;;; author : Sandra Loosemore +;;; date : 19 Aug 1992 +;;; + + +;;;==================================================================== +;;; Basic structure types +;;;==================================================================== + + +;;; Use this hash table for mapping names -> type descriptors + +(defvar *struct-lookup-table* (make-hash-table :test #'eq)) + +(defmacro lookup-type (name) + `(gethash ,name *struct-lookup-table*)) + + +;;; Do NOT add or remove slots from these DEFSTRUCTS without also +;;; changing the bootstrap code below!!! +;;; Do NOT try to give these structs complicated defaulting behavior!!! + +;;; All of our objects are subtypes of STRUCT. + + +(mumble::predefine (mumble::write object . maybe-stream)) + +(defun print-struct-object (object stream depth) + (declare (ignore depth)) + (mumble::write object stream) +; (format stream "#" (td-name (struct-type-descriptor object))) + ) + + +;;; Note that non-exported slots are prefixed with % to prevent +;;; accidental slot name collisions. + +(defstruct (struct + (:print-function print-struct-object) + (:predicate struct?) + (:constructor nil) ; never instantiated directly + (:copier nil)) + (type-descriptor nil :type t) + (%bits 0 :type fixnum) + ) + + +(defstruct (type-descriptor + (:include struct + (type-descriptor (lookup-type 'type-descriptor))) + (:conc-name td-) + (:constructor create-type-descriptor ()) + (:predicate nil) + (:copier nil)) + (name nil :type symbol) + (slots nil :type list) ; all slots, including inherited + (parent-type nil :type t) + (printer nil :type t) + (%local-slots nil :type list) ; "real" structure slots + (%bits-used 0 :type fixnum) + (%constructor nil :type symbol) + ) + +(defstruct (slot-descriptor + (:include struct + (type-descriptor (lookup-type 'slot-descriptor))) + (:conc-name sd-) + (:constructor create-slot-descriptor ()) + (:predicate nil) + (:copier nil)) + (name nil :type symbol) + (type nil :type t) + (default nil :type t) + (getter nil :type symbol) + (%bit nil :type (mumble::maybe fixnum)) + (%read-only? nil :type mumble::bool) + (%required? nil :type mumble::bool) + (%uninitialized? nil :type mumble::bool)) + + +;;; Helper function for bootstrapping. + +(defun create-slot-simple (prefix name type default + &optional read-only? required? uninitialized?) + (let ((sd (create-slot-descriptor))) + (setf (sd-name sd) name) + (setf (sd-type sd) type) + (setf (sd-default sd) default) + (setf (sd-getter sd) (symbol-append prefix name)) + (setf (sd-%read-only? sd) read-only?) + (setf (sd-%required? sd) required?) + (setf (sd-%uninitialized? sd) uninitialized?) + sd)) + + +;;; Initialize descriptors for the predefined struct types. + +(let ((struct-td (setf (lookup-type 'struct) + (create-type-descriptor))) + (type-td (setf (lookup-type 'type-descriptor) + (create-type-descriptor))) + (slot-td (setf (lookup-type 'slot-descriptor) + (create-type-descriptor)))) + ;; struct + (setf (td-type-descriptor struct-td) type-td) + (setf (td-name struct-td) 'struct) + (setf (td-%bits-used struct-td) 0) + ;; type-descriptor + (setf (td-type-descriptor type-td) type-td) + (setf (td-name type-td) 'type-descriptor) + (setf (td-%local-slots type-td) + (list (create-slot-simple 'td- 'name 'symbol nil) + (create-slot-simple 'td- 'slots 'list nil) + (create-slot-simple 'td- 'parent-type 't nil) + (create-slot-simple 'td- 'printer 't nil) + (create-slot-simple 'td- '%local-slots 'list nil) + (create-slot-simple 'td- '%bits-used 'fixnum 0) + (create-slot-simple 'td- '%constructor 'symbol nil) + )) + (setf (td-slots type-td) (td-%local-slots type-td)) + (setf (td-%bits-used type-td) 0) + (setf (td-%constructor type-td) 'create-type-descriptor) + (setf (td-parent-type type-td) struct-td) + ;; slot-descriptor + (setf (td-type-descriptor slot-td) type-td) + (setf (td-name slot-td) 'slot-descriptor) + (setf (td-%local-slots slot-td) + (list (create-slot-simple 'sd- 'name 'symbol nil) + (create-slot-simple 'sd- 'type 't nil) + (create-slot-simple 'sd- 'default 't nil) + (create-slot-simple 'sd- 'getter 'symbol nil) + (create-slot-simple 'sd- '%bit '(mumble::maybe fixnum) nil) + (create-slot-simple 'sd- '%read-only? 'mumble::bool nil) + (create-slot-simple 'sd- '%required? 'mumble::bool nil) + (create-slot-simple 'sd- '%uninitialized? 'mumble::bool nil) + )) + (setf (td-slots slot-td) (td-%local-slots slot-td)) + (setf (td-%bits-used slot-td) 0) + (setf (td-%constructor slot-td) 'create-slot-descriptor) + (setf (td-parent-type type-td) struct-td) + ) + + + +;;;===================================================================== +;;; Support for bit slots +;;;===================================================================== + +(eval-when (eval compile load) + (defconstant max-bits (integer-length most-positive-fixnum))) + +(defvar *bit-slot-getters* (make-array max-bits)) +(defvar *bit-slot-setters* (make-array max-bits)) + +(defmacro bit-slot-getter (i) `(svref *bit-slot-getters* ,i)) +(defmacro bit-slot-setter (i) `(svref *bit-slot-setters* ,i)) + +(defmacro define-bit-accessors () + (let ((results nil)) + (dotimes (i max-bits) + (let ((getter (intern (format nil "GET-BIT-~a" i))) + (setter (intern (format nil "SET-BIT-~a" i))) + (mask (ash 1 i))) + (push + `(progn + (mumble::define-integrable (,getter x) + (not (eql (the fixnum + (logand (the fixnum (struct-%bits x)) + (the fixnum ,mask))) + 0))) + (mumble::define-integrable (,setter v x) + (setf (struct-%bits x) + (if v + (the fixnum + (logior (the fixnum (struct-%bits x)) + (the fixnum ,mask))) + (the fixnum + (logandc2 (the fixnum (struct-%bits x)) + (the fixnum ,mask))))) + v) + (setf (bit-slot-getter ,i) ',getter) + (setf (bit-slot-setter ,i) ',setter)) + results))) + `(progn ,@results))) + +(define-bit-accessors) + + + + +;;;===================================================================== +;;; Random helper functions +;;;===================================================================== + +(defun quoted? (x) + (and (consp x) (eq (car x) 'quote))) + +(defun quoted-value (x) + (cadr x)) + +(defun unknown-type-error (type) + (error "Struct type ~s has not been defined." type)) + +(defun unknown-slot-error (type slot) + (error "Struct type ~s has no slot named ~s." type slot)) + +(defun lookup-type-descriptor (type) + (or (lookup-type type) + (unknown-type-error type))) + +(defun lookup-slot-descriptor (type slot) + (let ((td (lookup-type-descriptor type))) + (or (find slot (td-slots td) :key #'sd-name) + (unknown-slot-error type slot)))) + +(defun slot-getter-name (type slot) + (sd-getter (lookup-slot-descriptor type slot))) + +(defun sd-getter-function (sd) + (symbol-function (sd-getter sd))) + + + +;;;===================================================================== +;;; Struct-slot macro +;;;===================================================================== + +;;; Note that this can be SETF'ed only if type and slot are quoted. + +(defmacro struct-slot (type slot object) + (if (and (quoted? type) (quoted? slot)) + (struct-slot-compiletime (quoted-value type) (quoted-value slot) object) + (progn + (warn "Type and/or slot argument to STRUCT-SLOT not constant.") + `(struct-slot-runtime ,type ,slot ,object)))) + +(defun struct-slot-compiletime (type slot object) + (let ((sd (lookup-slot-descriptor type slot))) + `(the ,(sd-type sd) (,(sd-getter sd) (the ,type ,object))))) + +(defun struct-slot-runtime (type slot object) + (let ((sd (lookup-slot-descriptor type slot))) + ;; *** Could insert explicit type checks here. + (funcall (sd-getter-function sd) object))) + + +;;;===================================================================== +;;; Make macro and support +;;;===================================================================== + +(defmacro make (type . inits) + (make-aux type inits)) + +;;; Turn the call to MAKE into a call to the boa constructor. +;;; The arguments to the BOA constructor are those slots that have +;;; the required? flag set to true. If initializers for other slots +;;; are provided, turn these into SETFs. Bit attributes are always +;;; handled via SETF. + +(defun make-aux (type inits) + (let* ((td (lookup-type-descriptor type)) + (boa (td-%constructor td)) + (slots (td-slots td)) + (tempvar (gensym)) + (setfs '()) + (bits-inits '()) + (slot-inits '())) + (check-slot-inits type inits) + (dolist (s slots) + (let* ((name (sd-name s)) + (supplied? (mumble::assq name inits)) + (required? (sd-%required? s)) + (uninitialized? (sd-%uninitialized? s)) + (init (if supplied? + (progn + ;; *** Maybe want to suppress this warning. + ;;(when (not required?) + ;; (override-slot-init-warning type name)) + (cadr supplied?)) + (progn + ;; *** Maybe want to suppress this warning. + (when (and required? (not uninitialized?)) + (missing-slot-init-warning type name)) + (sd-default s))))) + (cond ((sd-%bit s) + (cond ((or (eq init 'nil) (equal init '(quote nil))) + ;; do nothing, bit already defaults to 0 + ) + ((and uninitialized? (not supplied?) required?) + ;; no default or init supplied, leave uninitialized + ) + ((constantp init) + ;; it must be a non-false constant, set bit to 1 + (push (ash 1 (sd-%bit s)) bits-inits)) + (t + ;; have to do runtime test + (push `(the fixnum (if ,init ,(ash 1 (sd-%bit s)) 0)) + bits-inits)))) + ((and required? (not uninitialized?)) + ;; The constructor takes the value as a positional argument. + (push init slot-inits)) + (supplied? + ;; Make a setf. + ;; No point in putting the same value in twice. + (unless (and (constantp init) (equal init (sd-default s))) + (push `(setf (,(sd-getter s) ,tempvar) ,init) setfs))) + (t nil)))) + (unless (null bits-inits) + (push `(setf (struct-%bits ,tempvar) + ,(cond ((null (cdr bits-inits)) + (car bits-inits)) + ((every #'constantp bits-inits) + (apply #'logior bits-inits)) + (t + `(the fixnum (logior ,@(nreverse bits-inits)))))) + setfs)) + (if (null setfs) + `(,boa ,@(nreverse slot-inits)) + `(let ((,tempvar (,boa ,@(nreverse slot-inits)))) + ,@(nreverse setfs) + ,tempvar)))) + +(defun override-slot-init-warning (type name) + (warn "Overriding default for slot ~s in MAKE ~s." + name type)) + +(defun missing-slot-init-warning (type name) + (warn "No initializer or default for slot ~s in MAKE ~s." + name type)) + +(defun check-slot-inits (type inits) + (dolist (i inits) + (lookup-slot-descriptor type (car i)))) + + + +;;;==================================================================== +;;; Update-slots macro +;;;==================================================================== + +;;; Note that type is a literal here. +;;; *** Could be smarter about merging setters for bit slots. + +(defmacro update-slots (type exp . inits) + (let ((temp (gensym))) + `(let ((,temp ,exp)) + ,@(mapcar #'(lambda (i) + `(setf (struct-slot ',type ',(car i) ,temp) ,(cadr i))) + inits)))) + + + +;;;==================================================================== +;;; With-slots macro +;;;==================================================================== + +;;; Note that type is a literal here. +;;; ***Could be smarter about merging accesses for bit slots. + +(defmacro mumble::with-slots (type slots exp . body) + (let ((temp (gensym))) + `(let* ((,temp ,exp) + ,@(mapcar #'(lambda (s) + `(,s (struct-slot ',type ',s ,temp))) + slots)) + ,@body))) + + +;;;==================================================================== +;;; Define-struct macro +;;;==================================================================== + + +;;; The rather strange division here is so that the call to MAKE +;;; works right. +;;; All INSTALL-STRUCT-TYPE does is fill in and install the type +;;; descriptor object. + +(defmacro define-struct (name . fields) + (multiple-value-bind (include type-template slots prefix predicate) + (parse-struct-fields name fields) + `(progn + (eval-when (eval compile load) + (install-struct-type + ',name + ',include + ',prefix + (make ,type-template) + ',slots)) + (define-struct-aux ,name ,include ,prefix ,predicate)))) + + +;;; This is the macro that actually creates the DEFSTRUCT expansion. + +(defmacro define-struct-aux (name include prefix predicate) + (let* ((td (lookup-type name)) + (slots (td-slots td)) + (local-slots (td-%local-slots td)) + (bit-slots (remove-if-not #'sd-%bit slots))) + `(progn + ;; Make the struct definition. + ;; *** could put the type descriptor for the default in a + ;; *** global variable; it might speed up reference. + (defstruct (,name + (:include ,include + (type-descriptor (lookup-type ',name))) + (:conc-name ,prefix) + ;; Disable the default keyword constructor. + ;; If you do this in AKCL, it will complain about + ;; the BOA constructor. Bogus!!! + ;; If you do this in WCL, it will just quietly ignore + ;; the BOA. + #-(or akcl wcl) (:constructor nil) + (:constructor ,(td-%constructor td) ,(make-boa-args slots)) + (:predicate ,predicate) + (:copier nil)) + ,@(mapcar + #'(lambda (s) + `(,(sd-name s) ,(sd-default s) + ;; CMU common lisp initializes &aux boa constructor + ;; slots to NIL instead of leaving them uninitialized, + ;; and then complains if this doesn't match the declared + ;; slot type. I think this is a bug, not a feature, but + ;; here's a workaround for it. + :type + #+cmu ,(if (sd-%uninitialized? s) + `(or ,(sd-type s) null) + (sd-type s)) + #-cmu ,(sd-type s) + ;; Can make slots read-only only if a setf-er is not + ;; required by MAKE. + :read-only ,(and (sd-%read-only? s) (sd-%required? s)))) + local-slots)) + ;; Make accessor functions for bit slots. + ,@(mapcar + #'(lambda (s) + (let ((place (symbol-append prefix (sd-name s))) + (getter (bit-slot-getter (sd-%bit s))) + (setter (bit-slot-setter (sd-%bit s)))) + `(progn + (mumble::define-integrable (,place x) (,getter x)) + ,@(unless (sd-%read-only? s) + `((mumble::define-setf ,place ,setter)))) + )) + bit-slots) + ',name) + )) + + + +;;; Determine which arguments to make explicit to the boa constructor. +;;; Basically, expect an explicit initializer for any slot that does not +;;; have a default supplied. +;;; Supplying slot names as &aux parameters to a boa constructor is +;;; supposed to suppress initialization. + +(defun make-boa-args (slots) + (let ((required-args '()) + (uninitialized-args '())) + (dolist (s slots) + (when (and (sd-%required? s) (not (sd-%bit s))) + (if (sd-%uninitialized? s) + (push (sd-name s) uninitialized-args) + (push (sd-name s) required-args)))) + ;; Gag. AKCL does the wrong thing with &AUX arguments; defstruct sticks + ;; another &AUX at the end of the lambda list. Looks like it will do + ;; the right thing if you just omit the uninitialized arguments from + ;; the boa arglist entirely. + #+akcl (nreverse required-args) + #-akcl + (if (null uninitialized-args) + (nreverse required-args) + `(,@(nreverse required-args) &aux ,@(nreverse uninitialized-args))) + )) + + +;;; Install the type descriptor, filling in all the slots. + +(defun install-struct-type (name include prefix td slots) + (let* ((parent-type (lookup-type-descriptor include)) + (bits-used (td-%bits-used parent-type)) + (local-slots '()) + (all-slots '())) + (dolist (s slots) + (multiple-value-bind + (slot-name type default bit read-only? required? uninitialized?) + (parse-slot-fields name s) + (let ((sd (create-slot-simple + prefix slot-name type default + read-only? required? uninitialized?))) + (push sd all-slots) + (cond (bit + (if (eql bits-used max-bits) + (error "Too many bit slots in DEFINE-STRUCT ~s." name)) + (setf (sd-%bit sd) bits-used) + (incf bits-used)) + (t + (push sd local-slots)))))) + (setf local-slots (nreverse local-slots)) + (setf (td-name td) name) + (setf (td-slots td) (append (td-slots parent-type) (nreverse all-slots))) + (setf (td-%local-slots td) local-slots) + (setf (td-%bits-used td) bits-used) + (setf (td-%constructor td) (symbol-append '%create- name)) + (setf (td-parent-type td) parent-type) + (setf (lookup-type name) td))) + + +;;; Struct field parsing. + +(defun parse-struct-fields (name fields) + (when (not (symbolp name)) + (error "Structure name ~s is not a symbol." name)) + (let ((include nil) + (type-template nil) + (slots nil) + (prefix nil) + (predicate nil)) + (dolist (f fields) + (cond ((not (consp f)) + (unknown-field-error f name)) + ((eq (car f) 'include) + (if include + (duplicate-field-error 'include name) + (setf include (cadr f)))) + ((eq (car f) 'type-template) + (if type-template + (duplicate-field-error 'type-template name) + (setf type-template (cadr f)))) + ((eq (car f) 'slots) + (if slots + (duplicate-field-error 'slots name) + (setf slots (cdr f)))) + ((eq (car f) 'prefix) + (if prefix + (duplicate-field-error 'prefix name) + (setf prefix (cadr f)))) + ((eq (car f) 'predicate) + (if predicate + (duplicate-field-error 'predicate name) + (setf predicate (cadr f)))) + (t + (unknown-field-error f name)))) + (values + (or include 'struct) + (or type-template + (and include + (td-name (td-type-descriptor (lookup-type-descriptor include)))) + 'type-descriptor) + (or slots '()) + (or prefix (symbol-append name '-)) + predicate))) + +(defun unknown-field-error (f name) + (error "Unknown field ~s in DEFINE-STRUCT ~s." f name)) + +(defun duplicate-field-error (f name) + (error "Field ~s appears more than once in DEFINE-STRUCT ~s." f name)) + + + +;;; Parsing for slot specifications. + +(defun parse-slot-fields (struct-name slot) + (let ((name nil) + (type t) + (default '*default-slot-default*) + (bit nil) + (read-only? nil) + (required? t) + (uninitialized? nil)) + (if (or (not (consp slot)) + (not (symbolp (setf name (car slot))))) + (invalid-slot-error slot struct-name)) + (dolist (junk (cdr slot)) + (cond ((eq (car junk) 'type) + (setf type (cadr junk))) + ((eq (car junk) 'default) + (setf default (cadr junk)) + (setf required? nil)) + ((eq (car junk) 'bit) + (setf bit (cadr junk))) + ((eq (car junk) 'read-only?) + (setf read-only? (cadr junk))) + ((eq (car junk) 'uninitialized?) + (setf uninitialized? (cadr junk))) + (t + (invalid-slot-error slot struct-name)))) + (values + name + type + default + bit + read-only? + required? + uninitialized? + ))) + +;;; Some implementations of DEFSTRUCT complain if the default value +;;; for a slot doesn't match the declared type of that slot, even if +;;; the default is never used. +;;; Using this variable as the default init form for such slots should +;;; suppress such warnings. + +(defvar *default-slot-default* nil) + +(defun invalid-slot-error (slot struct-name) + (error "Invalid slot syntax ~s in DEFINE-STRUCT ~s." slot struct-name)) + + + +;;;===================================================================== +;;; Printer hooks +;;;===================================================================== + +;;; Here is the macro for associating a printer with a structure type. + +(defmacro define-struct-printer (type function) + `(define-struct-printer-aux ',type (function ,function))) + +(defun define-struct-printer-aux (type function) + (let ((td (lookup-type-descriptor type))) + (setf (td-printer td) function) + type)) + + +;;;===================================================================== +;;; Imports +;;;===================================================================== + + +;;; Generic stuff + +(define-mumble-import struct) +(define-mumble-import struct?) +(define-mumble-import struct-type-descriptor) + + +;;; Predefined types, slots, and accessors +;;; Note: not all slots are exported. + +(define-mumble-import type-descriptor) +(define-mumble-import name) +(define-mumble-import slots) +(define-mumble-import parent-type) +(define-mumble-import printer) +(define-mumble-import td-name) +(define-mumble-import td-slots) +(define-mumble-import td-parent-type) +(define-mumble-import td-printer) + +(define-mumble-import slot-descriptor) +(define-mumble-import name) +(define-mumble-import type) +(define-mumble-import default) +(define-mumble-import getter) +(define-mumble-import sd-name) +(define-mumble-import sd-type) +(define-mumble-import sd-default) +(define-mumble-import sd-getter) + + +;;; Utility functions + +(define-mumble-import lookup-type-descriptor) +(define-mumble-import lookup-slot-descriptor) +(define-mumble-import sd-getter-function) + + +;;; Macros + +(define-mumble-import make) +(define-mumble-import struct-slot) +(define-mumble-import define-struct) +(define-mumble-import mumble::with-slots) +(define-mumble-import update-slots) +(define-mumble-import define-struct-printer) + + +;;; Field names for define-struct + +(define-mumble-import include) +(define-mumble-import type-template) +(define-mumble-import slots) +(define-mumble-import prefix) +(define-mumble-import predicate) + + +;;; Field names for slot options + +(define-mumble-import type) +(define-mumble-import default) +(define-mumble-import bit) +(define-mumble-import read-only?) +(define-mumble-import uninitialized?) + + diff --git a/cl-support/cl-support.lisp b/cl-support/cl-support.lisp new file mode 100644 index 0000000..4f82ce2 --- /dev/null +++ b/cl-support/cl-support.lisp @@ -0,0 +1,86 @@ +;;; cl-support.lisp -- compile-time support for building mumble +;;; +;;; author : Sandra Loosemore +;;; date : 10 Oct 1991 +;;; +;;; This file must be loaded before compiling the cl-definitions file. +;;; However, it is not needed when loading the compiled file. + +(in-package "MUMBLE-IMPLEMENTATION") + + +;;; Use this macro for defining an exported mumble function. + +(defmacro define-mumble-function (name &rest stuff) + `(progn + (eval-when (eval compile load) (export (list ',name) "MUMBLE")) + (defun ,name ,@stuff))) + + +;;; This is similar, but also does some stuff to try to inline the +;;; function definition. + +(defmacro define-mumble-function-inline (name &rest stuff) + `(progn + (eval-when (eval compile load) (export (list ',name) "MUMBLE")) +#+lcl + (lcl:defsubst ,name ,@stuff) +#-lcl + (progn + (proclaim '(inline ,name)) + (defun ,name ,@stuff)) + ',name)) + + +;;; Use this macro for defining an exported mumble macro. + +(defmacro define-mumble-macro (name &rest stuff) + `(progn + (eval-when (eval compile load) (export (list ',name) "MUMBLE")) + (defmacro ,name ,@stuff))) + + +;;; Use this macro for importing a random symbol into the MUMBLE +;;; package. This is useful for things that can share directly with +;;; built-in Common Lisp definitions. + +(defmacro define-mumble-import (name) + `(progn + (eval-when (eval compile load) (import (list ',name) "MUMBLE")) + (eval-when (eval compile load) (export (list ',name) "MUMBLE")) + ',name)) + + +;;; Use this macro for defining a function in the MUMBLE package that +;;; is a synonym for some Common Lisp function. Try to do some stuff +;;; to make the function compile inline. + +(defmacro define-mumble-synonym (name cl-name) + `(progn + (eval-when (eval compile load) (export (list ',name) "MUMBLE")) + (setf (symbol-function ',name) (symbol-function ',cl-name)) +#+lcl + (lcl:def-compiler-macro ,name (&rest args) + (cons ',cl-name args)) + ',name)) + + + +;;; Use this macro to define a type synonym. + +(defmacro define-mumble-type (name &rest stuff) + `(progn + (eval-when (eval compile load) (export (list ',name) "MUMBLE")) + (deftype ,name ,@stuff))) + + +;;; This macro is used to signal a compile-time error in situations +;;; where an implementation-specific definition is missing. + +(defmacro missing-mumble-definition (name) + (error "No definition has been provided for ~s." name)) + + + + + diff --git a/cl-support/cl-types.lisp b/cl-support/cl-types.lisp new file mode 100644 index 0000000..6fb625e --- /dev/null +++ b/cl-support/cl-types.lisp @@ -0,0 +1,90 @@ +;;; cl-types.lisp -- type-related stuff +;;; +;;; author : Sandra Loosemore +;;; date : 5 Oct 1992 +;;; + + +;;; Export CL symbols for type names + +(define-mumble-import t) + +#+lucid +(define-mumble-type mumble::procedure () 'system::procedure) +#+(or cmu akcl allegro mcl lispworks) +(define-mumble-type mumble::procedure () 'function) +#+wcl +(define-mumble-type mumble::procedure () 'lisp:procedure) +#-(or lucid cmu akcl allegro mcl lispworks wcl) +(missing-mumble-definition procedure) + +(define-mumble-type mumble::pair () 'cons) + +(define-mumble-import null) + +(define-mumble-type mumble::list (&optional element-type) + ;; *** Common Lisp provides no way to make use of the element type + ;; *** without using SATISFIES. + (declare (ignore element-type)) + 'list) + +(define-mumble-import symbol) + +(define-mumble-type mumble::char () 'character) +(define-mumble-type mumble::string () 'simple-string) +(define-mumble-type mumble::vector () 'simple-vector) + +(define-mumble-import number) +(define-mumble-import integer) +(define-mumble-import rational) +(define-mumble-import float) +(define-mumble-import fixnum) + +(define-mumble-type mumble::int () 'fixnum) + +(define-mumble-type mumble::table (&optional key-type value-type) + ;; *** Common Lisp provides no way to make use of the element type + ;; *** without using SATISFIES. + (declare (ignore key-type value-type)) + 'hash-table) + + +;;; Extensions + +(define-mumble-type mumble::enum (&rest values) + `(member ,@values)) + +(define-mumble-type mumble::tuple (&rest element-types) + ;; *** Common Lisp provides no way to make use of the element type + ;; *** without using SATISFIES. + (let ((n (length element-types))) + (cond ((< n 2) + (error "Too few arguments to TUPLE type specifier.")) + ((eql n 2) + 'cons) + (t + 'simple-vector)))) + +(define-mumble-type mumble::bool () 't) + +(define-mumble-type mumble::alist (&optional key-type value-type) + `(mumble::list (tuple ,key-type ,value-type))) + +(define-mumble-type mumble::maybe (type) + `(or ,type null)) + + + +;;; Functions, etc. + +(define-mumble-import the) +(define-mumble-synonym mumble::subtype? subtypep) + +(define-mumble-function-inline mumble::is-type? (type object) + (typep object type)) + +(define-mumble-macro mumble::typecase (data &rest cases) + (let ((last (car (last cases)))) + (if (eq (car last) 'mumble::else) + `(typecase ,data ,@(butlast cases) (t ,@(cdr last))) + `(typecase ,data ,@cases)))) diff --git a/cl-support/wcl-patches.lisp b/cl-support/wcl-patches.lisp new file mode 100644 index 0000000..3e9395c --- /dev/null +++ b/cl-support/wcl-patches.lisp @@ -0,0 +1,68 @@ +(in-package "LISP") + + +;;; The default version of this function has a bug with relative +;;; pathnames. + +(defun pathname->string (p) + (let ((dirlist (pathname-directory p))) + (format nil "~A~{~A/~}~A~A~A" + (case (car dirlist) + (:absolute "/") + (:relative "./") + (:up "../") + (t "")) + (cdr dirlist) + (nil->empty-string (pathname-name p)) + (if (null (pathname-type p)) "" ".") + (nil->empty-string (pathname-type p))))) + + +;;; The default version of this function defaults the C file to the +;;; wrong directory -- LOAD can't find it. + +(defun my-comf (file &key + (output-file (merge-pathnames ".o" file)) + (c-file (merge-pathnames ".c" output-file)) + (verbose *compile-verbose*) + (print *compile-print*) + (config *config*) + (pic? *pic?*) + only-to-c?) + (old-comf file + :output-file output-file + :c-file c-file + :verbose verbose + :print print + :config config + :pic? pic? + :only-to-c? only-to-c?)) + +(when (not (fboundp 'old-comf)) + (setf (symbol-function 'old-comf) #'comf) + (setf (symbol-function 'comf) #'my-comf)) + + +;;; WCL's evaluator tries to macroexpand everything before executing +;;; anything. Unfortunately, this does the wrong thing with +;;; top-level PROGN's -- it tries to expand macros in subforms before +;;; executing earlier subforms that set up stuff required to do the +;;; the expansion properly. + +(defun eval-1 (form venv fenv tenv benv) + (let ((new-form (macroexpand form *eval-macro-env*))) + (if (and (consp new-form) + (eq (car new-form) 'progn)) + (do ((forms (cdr new-form) (cdr forms))) + ((null (cdr forms)) (eval-1 (car forms) venv fenv tenv benv)) + (eval-1 (car forms) venv fenv tenv benv)) + (let ((expansion (expand new-form))) + (when (and (listp expansion) + (eq (car expansion) 'define-function)) + (setf (get (second (second expansion)) + :function-definition) + form)) + (eval/5 expansion venv fenv tenv benv)) + ))) + + -- cgit v1.2.3