summaryrefslogtreecommitdiff
path: root/cl-support/cl-definitions.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'cl-support/cl-definitions.lisp')
-rw-r--r--cl-support/cl-definitions.lisp1351
1 files changed, 1351 insertions, 0 deletions
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<=? char<=)
+
+(define-mumble-synonym mumble::char-ci=? char-equal)
+(define-mumble-synonym mumble::char-ci<? char-lessp)
+(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>=? string>=)
+
+(define-mumble-synonym mumble::string-ci=? string-equal)
+(define-mumble-synonym mumble::string-ci<? string-lessp)
+(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)
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-16 19:13:42 +0000