;;
;;      Name: Morphological Analyser Common Lisp conpatability
;;         functions and macros
;;
;;      Author:  Alan W Black  November 1986
;;
;;      Copyright Graeme Ritchie, Alan Black,
;;                Steve Pulman and Graham Russell  1987
;;
;;         ---------------------------------------------
;;         |    Not to be used for military purposes   |
;;         ---------------------------------------------
;;               
;;   Description:
;;     This defines a number of macros and functions that allow
;;     the franz lisp version of the morphological analyser to be
;;     run (and compiled) in Common Lisp
;;
;;     >>> WARNING <<<
;;     Note that although this defines some Franz Routines it only
;;     does so for the cases reuqired and there is NO guarantee 
;;     that all general cases are coped with.
;;     >>> WARNING <<<
;;
;;     I would like to thank Jeff Dalton of AIAI, Edinburgh for advice
;;     about the finer points of Common Lisp.
;;

(shadow '(declare allocate assoc assq catch eq 
		error gensym load member memq remove throw zerop))
#+LUCID(shadow '(delq))

(defvar D-LOADEDFILES nil)

(defmacro include (filename)
;;
;;  This is difficult becasue of the way kyoto common lisp compiles
;;  files.  Include includes things only the first time they are
;;  called, macros are not compiled.  They are evaluated during loading.
;;  If the file has been included before it is not included again.
;;
;;  note mafuncs should therefore be compiled first so that it gets the
;;  actaul load commands embedded in it
;;
   (cond
      ((member filename D-LOADEDFILES)
	 nil)        ;; do nothing
      (t
	 (let ( (stream (open filename)) )
	    (princ "Including: ") (princ filename) (terpri)
	    (setq D-LOADEDFILES (cons filename D-LOADEDFILES))
	    (cons
	       'progn
	       (D-ReadInAllS-Expressions
		  (read stream nil 'EOF)
		  stream)))
      )
   )
)

(defun D-ReadInAllS-Expressions (expr istream)
;;
;;  keeps reading s-expressions until eof is found
;;
   (cond
      ((eql expr 'EOF) (close istream) '(t))
      ((and (listp expr) (eql (car expr) 'defmacro))
	 (eval expr)    ;; eval macros at load time
	 (D-ReadInAllS-Expressions 
	    (read istream nil 'EOF) istream))
      (t
	 (cons
	    expr
	    (D-ReadInAllS-Expressions 
	       (read istream nil 'EOF) istream))))
)

(defmacro declare (&rest junk)
;;
;;  Shadows the Common Lisp declare and just ingnores
;;  the localf function declarations and changes the special
;;  declarations to proclaims
;;
   (let ((specials (assoc 'special junk)))
      (cond
	 ((null specials) nil)
	 (t
            `(proclaim (quote ,specials)))))
)

(defmacro add (&rest nums) `(+ ,@nums))

(defmacro add1 (num) `(+ 1 ,num))

(defmacro aexplodec (word)
;;
;;  This is what is used to split a string into a list of its
;;  characters
;;  It does not do the same thing as the franz thing as this returns
;;  a list of characters
;;
   `(map 'list #'(lambda (thing) (concat thing))
      (coerce (string ,word) 'list))
)

(defmacro aexploden (word)
   `(map 'list #'(lambda (thing)
			(intern (string thing)))
      (coerce (string ,word) 'list))
)

(defmacro allocate (&rest rest)
;; through this declaration away at present
   `(progn nil)
)

(defmacro alphalessp (c1 c2)
   `(string< (string ,c1) (string ,c2)))

(defmacro assoc (key alist)
;;  has to use equal test
   `(lisp:assoc ,key ,alist :test #'equal))

(defmacro assq (akey alist)
;;  simple one using eql
   `(lisp:assoc ,akey ,alist))

(defun attach (newcar oldlist)
;;  returns a list with newcar as the car and oldlist as the cdr
;;  but it has the same cons cell as the oldlist
   (rplaca
      (rplacd oldlist (cons (car oldlist) (cdr oldlist)))
      newcar)
)

(defmacro catch (form &optional tag)
;; change the order
   `(lisp:catch ,tag ,form))

(defun concatl (things)
;;  
   (let ((*print-case* :upcase))
   (intern
      (apply
         #'concatenate
         (cons 'string
            (map 'list #'(lambda (x) (format nil "~A" x)) things)))))
)


(defun concat (&rest rest)
   (concatl rest)
)

(defmacro copy (tree)
   `(copy-tree ,tree))

(defmacro delq (item list count)
   `(delete ,item ,list :test #'eql :count ,count))

(defmacro drain ()
   `(clear-output))

(defmacro eq (a b) `(eql ,a ,b))

(defmacro error (message)
;;   Makes the mssage a string then passes it on the CL error
;;   handler.
   `(lisp:error (string ,message))
)
  
(defmacro errset (form)
;;  not sure how to deal with this yet so ignore it
   form
)

(defmacro filepos (&rest args)
   `(file-position ,@args))

;(defun filepos (&rest args)
;;;  just keeps the stuff in core
   ;(cond
      ;((eql (length args) 2) (cadr args))
      ;(t nil)))

(defmacro gensym (&optional prefix)
;;
   (cond
      ((null prefix) `(lisp:gensym))
      (t `(lisp:gensym (string ,prefix)))
   )
)

(defmacro implode (charlist)
;;  only defined for lists of characters NOT numbers
   `(intern (concatenate 'string 
	(mapcar #'character ,charlist))))

(defmacro infile (filename)
;;
;;  Franz infile function.  returns a file stream
;;
   `(open ,filename :direction :input)
)

(defmacro lessp (&rest nums)
   `(< ,@nums)
)

(defmacro load (filename)
;;
   `(lisp:load (string ,filename)))

(defmacro member (element set)
;;  has to use equal test
   `(lisp:member ,element ,set :test #'equal))

(defmacro memq (element set)
;;  simple one using eql
   `(lisp:member ,element ,set))

(defmacro minus (num)
;;
   `(- 0 ,num))

(defmacro ncons (item)
   `(cons ,item nil))

(defmacro neq (a b)
   `(not (eql ,a ,b)))

(defmacro newsym (&optional prefix)
;;
   (cond
      ((null prefix) `(intern (string (lisp:gensym))))
      (t `(intern (string (lisp:gensym (string ,prefix)))))
   )
)

(defmacro outfile (filename)
;;
;;  Franz outfile function, open a file for writing
;;
   `(open ,filename :direction :output)
)

(defmacro pp-form (arg)
;; pretty printer
   `(pprint ,arg))

(defun ptime ()
;; this hacky solution will do the trick for the way I use ptime
   (list
      (get-internal-real-time)
      0))

(defmacro plus (&rest args)
   `(+ ,@args))

(defmacro readc (&rest args)
   `(intern (string (read-char ,@args))))

(defmacro remove (element set)
;;  has to use equal test
   `(lisp:remove ,element ,set :test #'equal))

(defmacro remq (element set)
;;  simple one using eql
   `(lisp:remove ,element ,set :test #'eql))

(defmacro sstatus (&rest rest)
;; ignored
   `(progn nil)
)

(defmacro throw (form &optional tag)
;; change the order
   `(lisp:throw ,tag ,form))

(defmacro times (&rest args)
   `(* ,@args))

(defun tyi (&optional port)
;;  have to check if standard input
   (cond
      ((or (null port) (eql port 't))
	 (read-char *standard-input* nil 'EOF))
      (t (read-char port nil 'EOF)))
)

(defun tyipeek (&optional port)
;;  have to check if standard input
   (cond
      ((or (null port) (eql port 't))
	 (peek-char nil *standard-input* nil 'EOF))
      (t (peek-char nil port nil 'EOF)))
)

(defun zerop (thing)
;;   cl zerop doesn't allow symbols only numbers
   (and (numberp thing) (lisp:zerop thing)))

(defun Compile-Map ()
;;
;;  Compile the functions for the analyser
;;    cause of a nasty feature in kcl they have to have a filename
;;    extension
;;
;;  Note the order of compilation IS significant cause of the hacky
;;  way I have done this.  (Its a problem with Kyoto Common Lisp
;;  or more correctly the C compiler can't cope with long files).
;;  At least it might be.  Include compiles to a prog or nil depending
;;  on whether the file has been included before or not during THIS
;;  compilation process.
;;
;;  Also there is bug in the C compiler optimiser on SUN release 2.0 and 3.0
;;  which it into an infinite loop, so I can't use the most optimal
;;  setting for the compiler. - This is fixed in 3.2
;;
   (proclaim '(optimize (speed 3) (safety 0)))
   (mapcar
      #'(lambda (fname)
	   (princ "Compiling ")
	   (princ fname) (terpri)
	   (compile-file fname))
      '("mafuncs.l" "maload.l" "morphan.l" "makesp.l" "makelex.l"
	"spdebug.l" "debug.l" "mkwgram.l" "mconcat.l" "analyse.l" "autorun.l"))
)
