(declare
   (/.cal /.sub /.his /.evl /.get /.kcl /.hissize /.curhis /.history
    /. ? /.hisym /.quitorg)
   special)
(defun init-history ((initfile (string-append (getenv "HOME") "/.utihistory")))
   (setq /.cal (character "&") /.sub (character "^") /.his (character "!"))
   (setq /.kcl (character ":") /.hisym '!)
   (setq /.evl 5 /.get 0)
   (setq /.hissize 15 /.curhis 0 /. 1)
   (setq /.history (vector /.hissize))
   (readmacro /.get (function (lambda nil (history-action (rind)))))
   (readmacro /.evl (function (lambda nil (eval (rind)))))
   (setq toplevel 'my-toplevel)
   (setq break 'my-break)
   (setq attention-handler 'my-break)
   (mapc '(ls vi cat echo pwd grep fgrep wc who cc a/.out make more)
         (function (lambda (x) (putprop x t 'shcommand))))
   (lets ((err:open-close
           (function (lambda (stream (where)) (throw 'inithis))))
          (err:end-of-file err:open-close)
          (his) (stream))
    (catch 'inithis
       (setq stream (inopen (stream (alloc initfile))))
       (setq his (read stream))
       (close stream)
       (and (consp his) (init-history* his)))))
(defun init-history* (hislist)
   (lets ((len (length hislist)))
    (and (< /.hissize len)
         (setq hislist (nthcdr (/- len /.hissize) hislist) len /.hissize))
    (fill-vector /.history hislist)
    (setq /.curhis (cond ((<= /.hissize len) 0) (t len)) /. (/1+ len))))
(defun sync-history ((fname (string-append (getenv "HOME") "/.utihistory")))
   (lets ((err:open-close
           (function (lambda (stream (where)) (close stream) (throw 'synchis))))
          (printlevel 0) (printlength 0) (stream) (i /.curhis))
    (catch 'synchis
     (setq stream (outopen (stream (alloc fname))))
     (princ "(" stream)
     (loop (print (vref /.history i) stream)
           (and (<= /.hissize (incr i 1)) (setq i 0))
           (and (= /.curhis i) (exit)))
     (princ ")" stream)
     (terpri stream))
     (close stream)
     t))
(defun my-toplevel nil
   (catch 'my-toplevel
    (do ((prompt prompt) (?) (/.c (skip-blank) (skip-blank)) (/.form))
        nil
        (cond ((eq /.c /.cal) (tyi) (eval (make-history `(call ,(readline)))))
              ((eq /.c /.sub)
               (tyi) 
               (cond ((setq /.form (subst* (rind) (rind) (find-event (/1- /.))))
                      (setq ? (toplev* (print /.form))))
                     (t (format "Modifier failed./n"))))
              ((eq /.c /.his)
               (tyi) 
               (setq ? (toplev* (print (history-action (rind))))))
	      ((eq /.c /.kcl)
	       (tyi)
	       (setq /.c (tyi))
	       (cond ((= /.c (character "b"))
		      (lets ((printlength 0)) (print (my-backtrace))))
		     ((= /.c (character "B"))
		      (mapc (nreverse (my-backtrace)) 'print))
		     ((= /.c (character "h")) (history))
		     ((= /.c (character "q")) (quit))
		     ((= /.c (character "r")) (toplevel))
		     ((= /.c (character "t")) (toplevel))
		     (t (princ "Undefined break command.") (terpri))))
              (t (setq ? (toplev* (rind))))))))
(defun subst* (from to x)
   (lets ((form (subst to from x))) (and (not (equal form x)) form)))
(defun toplev* (/.form) (print (myeval (make-history /.form))))
(defun myeval (/.form)
   (cond ((atom /.form) (eval /.form))
         ((consp (car /.form)) (eval /.form))
         ((and (symbolp (car /.form)) (definedp (car /.form))) (eval /.form))
         ((and (symbolp (car /.form))
               (get (car /.form) 'shcommand)
               (every (cdr /.form)
                      (function (lambda (x) (or (stringp x) (symbolp x))))))
          (eval `(call ,(apply 'string-append (inspace /.form)))))
         (t (eval /.form))))
(defun inspace (form)
   (cond ((atom form) form)
         (t `(,(car form) " " . ,(inspace (cdr form))))))
(defun skip-blank nil
   (lets ((c (tyipeek)))
    (loop (and (/0= (logand (vref readtable c) 8192)) (exit c))
          (tyi)
          (setq c (tyipeek)))))
(defun make-history (form)
   (vset /.history /.curhis form)
   (and (<= /.hissize (incr /.curhis 1)) (setq /.curhis 0))
   (incr /. 1)
   form)
(defun history-action (command)
   (cond ((eq command /.hisym) (find-event (/1- /.)))
         ((fixp command)
          (cond ((0> command) (find-event (/+ /. command)))
                (t (find-event command))))
         ((find-history command))))
(defun find-event (evno)
   (cond ((<= (max 0 (/- /. /.hissize)) evno (/1- /.))
          (vref /.history (evno2index evno)))
         (t (/.error evno))))
(defun evno2index (evno)
   (lets ((d (/- /. evno)) (x (/- /.curhis d)))
    (cond ((0> x) (/+ /.hissize x)) (t x))))
(defun find-history (command)
   (lets ((i /.curhis) (his /.hissize) (event))
    (loop (and (0> (decr i 1)) (setq i (/1- /.hissize)))
          (and (= i /.curhis) (/.error command))
          (setq event (vref /.history i))
          (cond ((consp event)
                 (and (equal command (car event)) (exit event))
                 (and (symbolp (car event))
                      (symbolp command)
                      (string-match (pname command) (pname (car event)))
                      (exit event)))))))
(defun string-match (key str)
   (lets ((kl (string-length key)) (i 0))
    (and (<= kl (string-length str))
         (loop (and (= i kl) (exit t))
               (and (# (sref key i) (sref str i)) (exit nil))
               (incr i 1)))))
(defun history nil
   (lets ((i /.curhis) (n (/- /. /.hissize)))
    (loop (print-history-line n (vref /.history i))
          (and (<= /.hissize (incr i 1)) (setq i 0))
          (incr n 1)
          (and (<= /. n) (exit)))))
(defun print-history-line (n event)
   (and (0< n) (progn (tyo 9) (prin1 n) (tyo 9) (print event))))
(defun change-history-size (newsize)
   (cond ((not (fixp newsize)) (princ "fixnum expected") (terpri))
         ((<= newsize 1) (princ "illegal history size") (terpri))
         (t (lets ((v (vector newsize)) (n newsize) (i /.curhis))
             (loop (and (0> (decr n 1)) (exit))
                   (and (0> (decr i 1)) (setq i (/1- /.hissize)))
                   (and (= i /.curhis) (exit))
                   (vset v n (vref /.history i)))
             (setq /.history v /.hissize newsize /.curhis 0)
             nil))))
(defun /.error (mesg)
   (prin1 mesg) (princ ": Event not found.") (terpri) (throw 'my-toplevel))
(defun my-break nil
   (lets ((prompt "@ ") (standard-input terminal-input)
          (standard-output terminal-output))
    (my-toplevel)))
(defun my-backtrace nil
   (lets ((b (backtrace))) (cond ((memq 'my-toplevel b)) (t b))))
(setq /.quitorg (getd 'quit))
(defun quit nil (sync-history) (funcall /.quitorg))
(init-history)
