;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;                                                          ;;;;;;;;
;;;;;;  All files in this directory and its subdirectories are  ;;;;;;;;
;;;;;;  copyright 1997, 1998, 1999, 2000, 2002, 2003.           ;;;;;;;;
;;;;;;  by Rafael D. Sorkin.  All rights reserved.              ;;;;;;;;
;;;;;;                                                          ;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;  bibliotek.TCL.l    Time-stamp:< 2003-Nov-10 13:48:28 16303.56700 >

; This file is intended to be universal (for true common lisp).
; Things specific to one or another flavor of TCL are in "sub-biblioteks" like
; ~/lisp/bibliotek.gcl.l 
;    
; NOTHING HERE SHOULD DEPEND ON MACROS DEFINED IN `BIBLIOTEK.MACROS.EL'

; Herein we set up some aliases and dummy functions for compatibility with
; elisp, and we provide for TCL some macros and functions which it lacks but
; which are built into elisp.  We also define here the TCL versions of some
; functions etc which need to be written differently in TCL and elisp.
; But mainly such should go elsewere, eg bibliotek.general.tcl.l or 
; bibliotek.tcl.coda.el (if we make such a bibliotek)

; Perhaps more of the functions we define here should be declared inline
; or made macros (if they aren't already).

;: Roster of functions, macros and aliases defined herein 
;  We also mention for some where they "really belong"
;
; defalias (function)
; defsubst (macro)
;
; defconst (alias for `defconstant')   (macro)
;
; copy-sequence (alias for `copy-seq') (function)
; setcar        (alias for `rplaca')   (function)
; setcdr        (alias for `rplacd')   (function)
; ratio         (alias for `/')        (function)
;
; reciprocal (function) [bibliotek.general]
; sgn        (function) [move to bibliotek.general.tcl.l ?]
;
;
; while    (macro)
; elisp-if (macro)
; pp       (macro)
; message  (macro)
;
; car-safe (function)
; remq     (function)
; concat   (function)
; fset     (function)
; setplist (function)
; put      (function)
;
; dummy-function (dummy function)
; write-region (aliased to dummy-function)
; getenv       (aliased to dummy-function)
; interactive  (aliased to dummy-function)

;: Package info goes here if required 

   ; (in-package  user) = favored form
   ; (in-package 'user) = archaic form

;: Make sure that none of our functions or macros are already present
;  in this version of TCL 
;
;;; TRY TO KEEP THIS SECTION UP TO DATE!

(defun kujaribu(symbol)(if(fboundp symbol)(error "~s already exists" symbol)))

(defvar *already-tested-for-duplicated-defs* nil) 

(unless *already-tested-for-duplicated-defs*
  (mapcar #'kujaribu '(

    defalias  defsubst  defconst  copy-sequence  setcar  setcdr 
    ratio     ratio*
    while     elisp-if  pp
    message   car-safe   remq   concat
    fset      setplist   put    
    reciprocal  1/      sgn
    dummy-function  write-region  getenv  interactive
    
    ))) 
(set '*already-tested-for-duplicated-defs* t) ; turns off further testing 


;: The function `defalias'

(defun defalias (sym def) 
  "\
 Provides the elisp function of this name, which makes `sym' an alias 
 for `def', where both sym and def should be symbols, the latter naming 
 a macro or a function (but not a special form).
 Example: (defalias 'card 'length)      \
  "  
  (cond
   ((macro-function def) (setf ( macro-function sym) ( macro-function def)))
   (t                    (setf (symbol-function sym) (symbol-function def)))))
  ;
  ; We handle separately the aliasing of (1) a macro and (2) a function.
  ; It appears to be impossible to alias a special form.  
  ; Notice that `macro-function' returns nil if its argument is not a macro,
  ; but `symbol-function' gives an error if its argument is not a function.

;: The macro `defsubst' 

;; This macro exists in elisp to tell the compiler that the function it defines
;; should be open coded.  Before really _using_ it in TCL, we should check its
;; syntax and test it.  Also cmucl has some problem with inlining!

(defmacro defsubst (name args &rest H)
  "\
 For now being treated as a dummy, but it might really work!  If it does, it
 will make its argument inline. "
  `(progn
     (declaim (inline ,name))  
     (deff ,name ,args ,@H)))


;: Set up some aliases of built-in stuff

(defalias 'defconst 'defconstant)

(defalias 'copy-sequence 'copy-seq)

(defalias 'setcar 'rplaca)              ; but the return value differs!

(defalias 'setcdr 'rplacd)              ; but the return value differs!

(defalias 'ratio '/)			

(defalias 'ratio* 'ratio)

;; GCL NOTE The system warns that ratio "is being redefined", but the
;; warning is spurious because there is no built in function named `ratio'
;; (and one can easily check that `ratio' is f-unbound on startup)

;: Define some macros

; These provide some macros that elisp has as builtins or which are needed for
; compatibilty with elisp

(defmacro while (test &rest body) 
  " The macro `while' for TCL"
  (list 'loop 'while test 'do (cons 'progn body)))

(defmacro elisp-if (A B &rest C)
  "\
 This is the elisp form of `if', for use with old elisp code.  
 It allows multiple forms in the ``else'' clause."
  (list 'if A B (cons 'progn C)))

(defmacro pp(x) `(let ((*print-length* nil)) (princ ,x)))

(defmacro message (&rest args)
  `(progn
     (format t ,@args)
     (terpri)))

 ;; Seems to work in gcl (if not then make separate version and move
 ;; each to its matching sub-bibilotek)

 ;; SEEMS to work in cmucl, and the TERPRI seems crucial in cmucl to get
 ;; immediate printing, rather than waiting for evaluation to finish.
 ;; (Drawback is you get newline after each message, is there another way?) 
 ;; But is it causing crashes?
 ;
 ; (defmacro message (&rest H)
 ;   " For TCL compatibility"
 ;   `(princ (format nil ,@H)))

 ; remark: `message' doesn't exist in gcl (not fboundp), but something of the
 ; same name does in some windowing facility of it. 


;: Provide some functions 

; We should probably try to inline some of the small functions defined here,
; like `memq' and `delq' or whatever, using the following syntax
;     (declaim (inline memq delq))  

; Unfortunately not all lisps have `ignore-errors'
; so can't define a universal `load-safe' here, a la cmucl

(defun car-safe (x) (if (consp x) (car x)))

(defun remq (x L) "remq:delq::remove:delete" (delq x (copy-list L)))

(defun concat (&rest seqs) 
  " This function exists in elisp, the result is always a string."
  (apply #'concatenate (cons 'string seqs)))

(defun fset (sym newval) 
   "\
 An elisp function for setting the ``function pointer'' of a symbol.  
 For many flavors of TCL, the new value must be a valid function definition
 (not macro, probably).  \
  "
   (setf (symbol-function sym) newval))

(defun setplist (sym newval)   
   "\
 An elisp function that sets the plist of a symbol. This provides it in TCL."
   (setf (symbol-plist sym) newval))

(defun put (sym prop val) 
   "\
 An elisp function that installs a property in the plist of a symbol. 
 This provides it in TCL."
   (setf (get sym prop) val))

(defun reciprocal (x) (/ 1 x)) 

(defalias '1/ 'reciprocal)

(defun sgn (x) 
  "\
 The signum function, returning -1 0 1
 This acts the same as the builtin `signum' except that we demand the
 argument to be real and we always return an integer.  \
  "
  (assert (realp x))
  (cond
   ((> x 0)  1)
   ((< x 0) -1)
   ((= x 0)  0)
   (t (error "Invalid argument to `sgn': ~s" x))))
 ;
 ; NOTE This is overridden for gcl in bibliotek.gcl.l

;: Some dummy functions needed for elisp compatibility 

 ; These are here just to stop compiler warnings, when a TCL compiler sees
 ; elisp code in some bibliotek containing a function that it doesn't
 ; recognize.

(defun dummy-function (&rest H) 
  (message 
   "You must have inadvertantly called a dummy function, args were ~s"
   H)
  "You must have inadvertantly called a dummy function")

(defalias 'write-region 'dummy-function)
(defalias 'getenv       'dummy-function)
(defalias 'interactive  'dummy-function)


;: e n d