path: root/cl-support/cl-definitions.lisp

;;; 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 clisp)
(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 clisp)
(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.

#+(or allegro clisp)
(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 clisp)
(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 clisp)
(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 clisp)
(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 clisp)
(missing-mumble-definition mumble::redefine)


#+(or cmu akcl mcl lispworks wcl clisp)
(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 clisp)
(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 clisp)
(define-mumble-import gensym)

#-(or lucid akcl wcl cmu allegro mcl lispworks clisp)
(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 clisp)
(define-mumble-macro mumble::with-compilation-unit (options &body body)
  (declare (ignore options))
  `(progn ,@body))

#-(or lucid allegro cmu akcl mcl lispworks wcl clisp)
(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))

#+clisp
(define-mumble-function mumble::getenv (string)
  (ext: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 clisp)
(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)

#+clisp
(define-mumble-synonym mumble::exit ext:exit)

    
#-(or lucid allegro cmu akcl mcl lispworks wcl clisp)
(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 clisp)
(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 clisp)
(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 clisp)
(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 clisp)
(missing-mumble-definition mumble::gc-messages)


(define-mumble-import identity)