;;; -*- Mode: LISP; Package: CLISP; Base: 10; Syntax: Common-lisp -*-
;;;
;;;                 RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;; Technical Data and Computer Software Clause at 52.227-7013 of the DOD
;;; FAR Supplement
;;;
;;;		  BOLT BERANEK AND NEWMAN INC.
;;;		        10 Moulton Street
;;;		       Cambridge, MA 02238
;;;		          617-491-1850			
;;;

(in-package "CLISP")
;#+ :3600
;(in-package 'clisp ':use 'CL)
;#+ :ti
;(in-package 'clisp ':use 'lisp)

(export '($$ITERATE $$LP
		    $$OUT
		    $$VAL
		    ACCESSFN
		    ACCESSFNS
		    ADD1
		    ALWAYS
		    ARG
		    ARRAYBLOCK
		    ARRAYRECORD
		    ASKUSER
		    ASSOCRECORD
		    ASSQ
		    ATOMRECORD
		    BIND
		    BLOCKRECORD
		    CACCESSFNS
		    CHCON
		    CHCON1
		    CLISP-TRANSLATE
		    CLISPARRAY
		    COLLECT
		    CONCAT
		    COPYING
		    CREATE
		    DREMOVE
		    DREVERSE
		    EACHTIME
		    EQLENGTH
		    EQMEMB
		    FASSOC
		    FETCH
		    FFETCH
		    FLENGHT
		    FMEMB
		    FOR
		    FREPLACE
		    FROM
		    HASHLINK
		    HASHRECORD
		    IN
		    INITRECORD
		    INSIDE
		    JOIN
		    L-CASEP
		    MAPRINT
		    MEMQ
		    MKATOM
		    MKLIST
		    MYPACK*
		    NCHARS
		    NCONC1
		    NEQ
		    NEVER
		    NLEFT
		    NLISTP
		    NTHCHAR
		    NTHCHARCODE
		    OF
		    ON
		    PACK
		    PACK*
		    PACKC
		    PRIN2
		    PRINT-SPACES
		    PRINTPARA
		    PROPRECORD
		    PUSHLIST
		    PUTASSOC
		    PUTHASH
		    PUTPROP
		    RECORD
		    REPEATUNTIL
		    REPEATWHILE
		    REPLACE-CONS
		    REPLACE-CONS-PARTS
		    REUSING
		    SAFE-GET
		    SETQQ
		    SMALLP
		    SMASHING
		    STRPOS-WITHOUT-WILDCARD
		    STRPOSL
		    SUB1
		    SUBATOM
		    SUBSTRING
		    SUM
		    SWAP
		    SYNONYM
		    TAB
		    TCONC
		    THEREIS
		    TO
		    TYPE?
		    TYPENAME
		    TYPERECORD
		    U-CASE
		    U-CASEP
		    UNTIL
		    USING
		    VALUE-IF-LISTP
		    VALUE-IF-NUMBERP
		    VALUE-IF-TAILP
		    CLISP-WHEN 
		    WHILE
		    WITH
		    CLISP-UNLESS
		    _
		    ) 'clisp)

(defmacro CLISP-WHEN (test &Rest Args)
  `(if ,test (progn ,@args)))

(defmacro CLISP-UNLESS (test &Rest Args)
   `(if ,test nil (progn ,@Args)))

;;; A very odd mix of things.  This compatability package was once upon a time implemented
;;; in Franz Lisp.  What we see here are artifacts of that implementation as well as some
;;; new function that provide either low level support or emulate forms that are to hard
;;; to translate directly.

(defmacro memq (key list)
  `(member ,key ,list :test #'eql))

(defmacro assq (key list)
  `(assoc ,key ,list :test #'eq))

;(defmacro putprop (sym prop val)
;  `(setf (get ,sym ,prop) ,val))

(defmacro puthash (sym val harray)
  `(setf (gethash ,sym ,harray) ,val))

;(defmacro add1 (val)
;  `(1+ ,val))

;(defmacro sub1 (val)
;  `(1- ,val))

(defmacro neq (one two)
  `(not (eq ,one ,two)))

(defmacro smallp (num)
  `(integerp ,num))

(defmacro maprint (lst &optional file left right sep pfn junk)
  (let ((cst (gensym)))
    `(let ((,cst (format nil "~@[~a~]~~{~~a~~^~a~~}~@[~a~]" ,left (or ,sep " ") ,right)))
       (format (or ,file t) ,cst ,lst))))

;(defun nleft (lst count &optional tail)
;  (let* ((tl (length tail))(lstlen (length lst))
;	 (offset (+ count tl)))
;    (if (eql offset lstlen) lst
;	(if (< offset lstlen)
;	    (nthcdr (- lstlen offset) lst)))))

;;; Changed dremove to bring it in line with Interlisp DREMOVE,
;;; i.e. use EQ, modify list, return list. Note that (setq a '(1)) (dremove 1 a) returns NIL
;;; but leaves a to be (1)     Jos 9/6/85

(defun dremove (x lst)
  (cond ((null lst) lst)
	((null (cdr lst)) 
	 (CLISP-UNLESS (eq x (car lst)) lst))
	((eq x (car lst))
	 (rplaca lst (cadr lst))
	 (rplacd lst (cddr lst))
	 (dremove x lst))
	(t (dremove$1 x lst)
	   lst)))

(defun dremove$1 (x lst)
  (cond ((null (cdr lst)))
	((eq x (cadr lst))
	 (rplacd lst (cddr lst)) 
	 (dremove$1 x lst))
	(t (dremove$1 x (cdr lst)))))

(defmacro dreverse (lst)
  `(nreverse ,lst))

(defun mypack* (&rest them)
  (format nil "~{~a~}" them))

(defun pack* (&rest them)
  (read-from-string (format nil "~{~a~}" them)))

(defun pack (them)
  (read-from-string (format nil "~{~a~}" them)))

#+ignore(defmacro nconc1 (lst val)
  `(setf (cdr (last ,lst)) (list ,lst)))

(defmacro nconc1 (lst val)
  `(nconc  ,lst (list ,val)))

;(defmacro nlistp (expr)
;  `(not (consp ,expr)))

(defmacro value-if-listp (expr)
  (let ((var (gensym)))
    `(let ((,var ,expr))
       (CLISP-WHEN (listp ,var) ,var))))

(defmacro value-if-numberp (expr)
    (let ((var (gensym)))
    `(let ((,var ,expr))
       (CLISP-WHEN (numberp ,var) ,var))))

(defmacro safe-get (expr propform)
  (let ((var (gensym)))
    `(let ((,var ,expr))
       (CLISP-WHEN (symbolp ,var)
	 (get ,var ,propform)))))


(defun replace-cons-parts (cons car cdr)
  (setf (car cons) car)
  (setf (cdr cons) cdr))

(defun replace-cons (oldcons newcons)
  (replace-cons-parts oldcons (car newcons)(cdr newcons)))


(defmacro value-if-tailp (sub list)
  (let ((var (gensym)))
    `(let ((,var ,sub))
       (CLISP-WHEN (tailp ,var ,list) ,var))))


;(defun u-casep (object)				;could write this with ever but every 
;  (let ((real (typecase object			;doesn't work.  Bug to be reported.
;		(string object)
;		(symbol (symbol-name object))
;		(otherwise (format nil "~S" object)))))
;    (for i from 0 to (1- (length real)) bind temp always
;	  (or (upper-case-p (setq temp (elt real i)))
;	      (not (alpha-char-p temp))))))

;(defun l-casep (object)
;  (let ((real (typecase object
;		(string object)
;		(symbol (symbol-name object))
;		(otherwise (format nil "~S" object)))))
;    (for i from 0 to (1- (length real)) bind temp always
;	  (or (lower-case-p (setq temp (elt real i)))
;	      (not (alpha-char-p temp))))))

(defun u-case (object)
       (typecase object
                 (string (string-upcase object))
                 (symbol object)
                 (otherwise (format nil "~S" object))))


;(defun print-spaces (countarg file)
;  (for i from 1 to countarg do (format file " ")))

(defmacro flength (item) `(length ,item))
(defmacro fmemb   (item world) `(member ,item ,world))
(defmacro fassoc  (item world) `(assoc  ,item ,world))

(defun putassoc (key value list)
  (prog ((x list))
     lp
	(and (null x) (return nil))
	(cond ((and (consp (car x))(eq key (caar x)))
	       (setf (cdar x) value)
	       (return value))
	      ((null (cdr x))
	       (push (cons key value) (cdr x))
	       (return value)))
	(setq x (cdr x))
	(go lp)))

(defun typename (object)
  (typecase  object
    ((or symbol null) 'litatom)
    (cons             'listp  )
    (fixnum           'fixp   )
    (float            'floatp )
    (string           'stringp)
    (t                (type-of object))))


(defun eqmemb (a b)
  (or (eq a b)
      (and (consp b)(memq a b))))

(DEFUN mklist (unknown)
  (if (listp unknown) unknown
      (list unknown)))



(defun prin2 (x &optional file &rest ignore)
  (format (or file t) "~s" x))

(defun tab   (x &optional minspace file)   ;this could be done better
  (format (or file t) (make-string x :initial-element #\ )))

(defun printpara (&optional dummy dummy2 l dum3 dum4 file)
  dummy dummy2 dum3 dum4				;are ignored
  (format (or file t) "~a~%" l))

(defmacro setqq (a b)
  `(setq ,a ',b))

;(defmacro arg (length index)
;  `(elt clisp:interlisp-no-spread-args (1- ,index)))


(defun eqlength (list n)
  (if (and (numberp n)(listp list)(>= n 0))
	(do ((n n (1- n))(list list (cdr list)))
	    ((or (zerop n)(null list))(and (null list)(zerop n))))
	(error "Illegal argument to eqlength") ))

(defun nlambda-function-p (function-spec)
  (and (fboundp function-spec)
       (or (macro-function function-spec)(special-form-p function-spec))))

(defun lambda-function-p (function-spec)
  (and (fboundp function-spec)
       (not (or (macro-function function-spec)(special-form-p function-spec)))))