;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLISP -*-
;;;
;;;                 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")

;;; STRING FUNCTIONS (common lisp implementation of interlisp functions):
;;; It is far, far simpler to implement these directly than try to translate them.
;;; Many function are do just part of their InterLisp counterparts, enough to make
;;; NIKL and IRUS work.

;;; Note: for compatibility with interlisp functions, arguments and return values assume
;;; string indexing begins at 1 (rather than 0)


;;; Function to search STR beginning at character number START for characters in 
;;; list A; returns smallest index into STR that matches one of characters in A.
;;; If NEG is true, function searches for a character not in A.  

;(defun STRPOSL (a str &optional start  neg)	;
;  ;; search STR until character is found that is in (or not in) A.
;  (let* ((str (coerce-string str))
;	 (start (or start 1))
;	 (start (if (< start 0) (+ (length str)start) (1- start))))
;    (do ((index start (1+ index))
;	 (chars-a (mapcar #'(lambda (a) (coerce a 'cl:character)) a)))
;	((= index (length str)))
;      (when
;	(if neg
;	    (not (memq (char str index) chars-a))
;	    (memq (char str index) chars-a))
;	(return (1+ index))))))


;;; Function to search for PAT in STR beginning at character number START; returns beginning
;;; position of PAT in STR.  If ANCHOR is true, only compare characters beginning at START,
;;; and return nil if comparison fails.  Otherwise, continue searching until end of STR.
;;; If TAIL is true, return position of first character after PAT.
;;; Note: no wildcard matching in this version.

;(defun STRPOS-WITHOUT-WILDCARD (pat string &optional (start 1) (anchor nil) (tail nil) &rest junk)
;  junk     ;  This is an hackish way to avoid compiler warnings.  Until (declare (ignore.. works
;  (let* ((string (coerce-string string))
;	 (start (or start 1))
;	 (start (if (< start 0)(+ (length string) start) (1- start)))
;	 (pat (coerce-string pat))
;	 (index  (if anchor
;		    (search pat string :start2 start :end2 (length pat))
;		    (search pat string :start2 start))))
;    (when index
;      (if tail
;	  (setq index (+ index (length pat) 1))
;	  (setq index (1+ index))))
;    index))


;;; Function returns substring consisting of the Nth through Mth characters of X.
;;; X is coerced into a string; a negative ending position M means substring ends M
;;; characters from end of string X

(defun SUBSTR (x n m)
  (let ((string-x  (if (stringp x) x (format nil "~a" x))))
    (CLISP-WHEN (minusp m)
	(setq m (1+ (+ (length string-x) m))))
    (subseq string-x (1- n) m)))

;(defun substring (x n m)
;  (let* ((string-x (coerce-string x))(strlen (length string-x)))
;    (let ((m (param-for-substring m strlen))(n (param-for-substring n strlen)))
;      (if (< m n) nil
;	  (subseq string-x n (1+ m))))))

;(defun param-for-substring (pick limit)
;  (if (not(numberp pick)) (1- limit)
;      (if (minusp pick)
;	  (+ pick limit)
;	  (1- pick))))

;;; Function to concatenate items in a list into a string.
(defun CONCATLIST (args &aux (str ""))
  (dolist (arg args)
    (setq str  (format nil "~a~a" str arg)))
  str)


;;; Function to concatenate (copies of) it arguments.
(defun CONCAT (&rest args)
  (concatlist args))


;;; coerce just about anything into a string, only builds a string if it has too.
(defun coerce-string (x)
  (typecase x
    (symbol (symbol-name x))
    (string x)
    (t (format nil "~a" x))))



(defun nchars (x  &rest ignore)
  (let ((string-x (coerce-string x)))
    (length string-x)))

(defun nthchar (x n &rest ignore)
  (let ((string-x (coerce-string x)))
    (Let ((len (length string-x))(off (1- n)))
      (if (> n 0) (if (< off len) (elt string-x off))
	  (progn (setq off (+ n len))
		 (if (>=  off 0) (if (< off len)(elt string-x off))))))))

(defun nthcharcode (x n &optional ignore)
  (let ((string-x (coerce-string x)))
    (char-int (nthchar string-x n))))

(defmacro chcon1 (x)
  `(nthcharcode ,x 1))

(defun chcon (x)
  (map 'list #'char-int (coerce-string x)))


(defun packc (x)
  (intern (map 'string #'int-char x)))


;;; warning warning warning (with flailing arms) this function will do readmacro 
;;; interpretation of the characters in the string!!!!!!!
 
;(defun subatom (sym n m)
;  (let ((olepackage *package*))
;    (unwind-protect
;	(progn (CLISP-WHEN (symbolp sym)(in-package (symbol-package sym)))
;	       (mkatom (substring sym n m)))
;      (in-package olepackage))))



(defun mkatom (item)
  (read-from-string (coerce-string item)))