(in-package 'user)
;;  Note: patched 1/17/90 to handle name conflicts with
;;  Lucid Common Lisp.  Sigh...

;;  --------------------------------------
;;  T-in-Common LISP Compatibility Package
;;  --------------------------------------

;;  Load this code into Common LISP to make it resemble T.
					      
;;  Preliminaries
;;  -------------

;;  the symbol else is given the value T
(defconstant else T)

;;  T's define special form.
;;  This definition of define makes it simple and efficient
;;      to give T names to Common LISP procedures.
;;  It also allows the procedures to be passed as arguments
;;      without #'ing them.
(defmacro define (name &rest body)
  (cond ((and (atom name)
              (functionp (car body)))
         `(progn
            (setf (symbol-function ',name)
                  (symbol-function ',(car body)))
            (defvar ,name #',name)))
        ((atom name)
         `(defvar ,name ,@body))
        ((null (cdr (last name)))    ;; proper-list?
         `(progn
            (defun ,(car name) ,(cdr name) ,@body)
            (defvar ,(car name) #',(car name))))
        (else
         `(progn
            (defun ,(car name)
              ,(append (subseq name 1 (length name))
                       (list '&rest (cdr (last name))))
              ,@body)
            (defvar ,(car name) #',(car name))))))

;;  Chapter 2   --  Tutorial Introduction
;;  -------------------------------------
;;  Note:
;;    reset and stop are implementation dependent in Common LISP
;;    no herald form in Common LISP
(define  remainder          rem)
(define  quotient           truncate)
(define  ->integer          truncate)
(define  ->float            float)
(define  add1               1+)
(define  subtract1          1-)
(define  equal?             eql)
(define  less?              <)
(define  greater?           >)
(define  not-equal?         /=)
(define  not-less?          >=)
(define  not-greater?       <=)
(define  zero?              zerop)
(define  positive?          plusp)
(define  negative?          minusp)
(define  number?            numberp)
(define  integer?           integerp)
(define (ratio? obj) (and (rationalp obj) (not (integerp obj))))
(define  float?             floatp)
(define  even?              evenp)
(define  odd?               oddp)


;;  Chapter 3   --  Lists
;;  ---------------------
(define  symbol?            symbolp)
(define  pair?              consp)
(define  atom?              atom)
(define  list?              listp)
(define (proper-list? l) (and (pair? l) (null? (cdr (last l)))))
(define  null?              null)
(define  eq?                eq)
(define  alikev?            equalp)     ;;  sort of ...
(define (t-nth list n) (nth n list))    ;;  switch arguments
(define (t-nthcdr list n) (nthcdr n list))  ;;  switch arguments
(define (lastcdr list) (cdr (last list)))
(define (sublist l start count)
    (subseq l start (+ start count)))
(define  any?               some)       ;;  fn problem
(define  every?             every)      ;;  fn problem
(define  memq?              member)
(define (mem? pred obj list)            ;;  fn problem
  (member  obj list :test pred))
(define  delq               delete)
(define (del pred obj list)             ;;  fn problem
  (delete obj list :test pred))
;(define  cl-map             map)        ;;  ** switch **
(define t-map                mapcar)     ;;  fn problem
(define  substq             subst)
(define (t-subst pred new old tree)     ;;  switch arguments
  (subst new old tree :test pred))
(defmacro t-push (l obj)                ;;  switch arguments
  `(push ,obj ,l))
(define  assq               assoc)
(define (ass pred item a-list)          ;;  fn problem
  (assoc item a-list :test pred))
(define (put x y z) (setf (get x y) z))

;;  Chapters 4 - 6  --  Recursion, Let/Set, Characters and Strings
;;  --------------------------------------------------------------
;;  Note:
;;    set is an existing CL function with a different meaning
(defmacro t-set (loc val) `(setf ,loc ,val))
;; Note: 1/17/90
;; Apparently string-append is now part of CL
;;(define (string-append . args)
;;    (apply #'concatenate 'string args))
(define (concatenate-symbol . args)
    (intern (apply #'string-append
                   (mapcar #'princ-to-string args))))
(define  char?              characterp)
(define  string?            stringp)
(define  alphabetic?        alpha-char-p)
(define  digit?             digit-char-p)
(define  uppercase?         upper-case-p)
(define  lowercase?         lower-case-p)
(define  charn=             char\=)
(define (string-empty? string) (string= string ""))
(define  string-equal?      string=)
(define  string-length      length)
(define (string-head string) (char string 0))
(define (string-tail string) (subseq string 1))
(define  string-elt         elt)
(define (string-nthtail string n) (subseq string n))
(define  substring          sublist)            ;; defined above
(define  string-posq        position)
(define (map-string proc str)
  (map 'string proc str))          
(define  char->ascii        char-code)
(define  ascii->char        code-char)
(define (list->string l) (coerce l 'string))
(define (string->list s) (coerce s 'list))
(define  symbol->string     string)
(define  string->symbol     intern)
(define  char->string       string)

;;  Chapter 7   --  Ports, Input and Output
;;  -----------------------------------------
;;  Note:
;;      eof check built into read functions
;;      unread-char takes character argument
;;      peek-char takes type argument
;;      open slightly different
;;      implementation dependent: hpos, line-length
;;      reverse arguments:  write-string, write-char
(define (standard-input)    *standard-input*)
(defsetf standard-input () (val)
    `(setq *standard-input* ,val))
(define (standard-output)   *standard-output*)
(defsetf standard-output () (val)
    `(setq *standard-output* ,val))
(define (write-spaces port count)
    (dotimes (c count repl-wont-print)
             (write-char #\space port)))
(define  port?              streamp)
(define  output-port?       output-stream-p)
(define  input-port?        input-stream-p)
(define  newline            terpri)
(define  pretty-print       pprint)
(define  display            princ)
(define  string->input-port make-string-input-stream)
(define  file-exists?       probe-file)
(define repl-wont-print (values))   ;;  slightly different
(defconstant eof (gensym "EOF"))
(define (eof? x) (eq? x eof))
(define (t-read port) (read port nil eof))
(define (t-read-line port) (read-line port nil eof))
(define (t-read-char port) (read-char port nil eof))
(define (t-peek-char port) (peek-char nil port nil eof))

;;  Chapter 8   -- Lambda and Labels
;;  --------------------------------
;;  Note:
;;      no special cond syntax
;;      labels in CL cannot be used to define variables.
;;          also, syntax is slightly different:
;;      T:  (labels (((fn-name vars) body) ...) . body)
;;      CL: (labels ((fn-name (vars) body) ...) . body)
(define  procedure?         functionp)

;;  Chapter 9   -- Control
;;  ----------------------
;;  Note:
;;      no select form
;;      T-block  : progn
;;      T-catch  : block
;;      T-block0 : prog1


;;  Chapter 10  -- Debugging
;;  ------------------------
;;  Note:
;;      check-arg === check-type + assert
;;      recklessness, akin to (declare (optimize ...))
;;      (load-noisily?) is like *load-verbose*
;;      debug is implementation dependent
(define  argspectrum        describe)
(define  transcript-on      dribble)   ;; !!
(define  transcript-off     dribble)   ;; !!
(define  pp                 pprint)    ;;  fn problem
(define  where-defined      describe)  ;;  sort of,...
(define  breakpoint         break)

;;  Chapter 11  -- Macros
;;  ---------------------
;;  Note:
;;      no port-read-table
;;      repl-prompt is implementation dependent
(defmacro define-syntax (name &rest body)
    (cond
      ((null (cdr (last name)))    ;; proper-list?
       `(defmacro ,(car name) ,(cdr name) ,@body))
      (else
       `(defmacro ,(car name)
                  ,(append (subseq name 1 (length name))
                           (list '&rest (cdr (last name))))
                  ,@body))))
(t-set standard-read-table *readtable*)
(define  make-read-table  copy-readtable)
(define (read-table-entry read-table char)
    (get-macro-character char read-table))
(defsetf read-table-entry (read-table char) (function)
    `(set-macro-character ,char ,function ,read-table))

;;  Chapter 12  -- Structures
;;  -------------------------
;;  Note:  Anonymous structures not supported.
(define-syntax (define-structure-type name . slots)
    `(progn
       (defstruct ,name ,@slots)
       (define (concatenate-symbol ',name '?)
               (concatenate-symbol ',name '-p))))
(defmacro increment (x) `(incf ,x))
(defmacro decrement (x) `(decf ,x))

;;  Chapter 13  -- Objects
;;  ----------------------
;;  See Common LOOPS, cited above.
;;  Also, structures can be used as objects for many applications.
(define (generate-symbol x)
    (gensym (princ-to-string x)))

;;  Chapter 14  -- Vectors
;;  ----------------------
;;  Note:
;;      Common LISP directly supports multidimensional arrays
;;      Common LISP directly supports hash tables
;;      Common LISP directly supports random numbers.
(define (list->vector l) (coerce l 'vector))
(define (vector->list v) (coerce v 'list))
(define  vref               svref)
(define  vector?            vectorp)
(define  vector-length      length)
(define (vset vector index object)
    (setf (svref vector index) object))
(define  make-vector        make-array)
(define  vector-fill        fill)
(define (walk-vector procedure vector)
  (map nil procedure vector)) 
(define  copy-vector        copy-seq)
(define (vector-pos pred obj vec)
    (position obj vec :test pred))
(define  vector-posq        position)
(define  tree-hash          sxhash)
(define  hash-table?        hash-table-p)
(defmacro exchange (x y) `(rotatef ,x ,y))
(defstruct delayed-obj (forced? nil) val proc)
(define  delay?             delayed-obj-p)
(defmacro delay (form)
   `(make-delayed-obj :proc #'(lambda () ,form)))
(define (force x)
  (cond ((not (delay? x)) x)
        ((delayed-obj-forced? x) (delayed-obj-val x))
        (else (setf (delayed-obj-forced? x) t)
              (setf (delayed-obj-val x)
                    (funcall (delayed-obj-proc x))))))

;;  Chapter 15  -- Environments and EVAL
;;  ------------------------------------
;;  Note:
;;      Common LISP is lexically scoped
;;      bind is similar to special, but not the same
;;      packages are like environments
;;      can import and export between packages.

;;  Chapter 16  -- Efficiency and Compilation
;;  -----------------------------------------
(define  comfile            compile-file)