perm filename UPROCS.LSP[SCH,LSP] blob sn#688858 filedate 1982-11-14 generic text, type T, neo UTF8
;;; -*-LISP-*-

(HERALD UPROCS "")

(eval-when (compile) (load "scm:umacro"))


(DECLARE (SPECIAL *LISP-IMPORTS*))

(DEFUN ADD-TO-LISP-IMPORTS (L)
  (SETQ *LISP-IMPORTS* (APPEND L *LISP-IMPORTS*)))


(DEFUN STRINGP (EXP)
  (AND (SYMBOLP EXP)
       (GET EXP '+INTERNAL-STRING-MARKER)))

(DEFUN BUTLAST (X)
  (COND ((NULL X) NIL)
	((NULL (CDR X)) NIL)
	(T (CONS (CAR X) (BUTLAST (CDR X))))))

(DEFUN COERCE-DOWNWARD (X)
  (OR (NUMBERP X)
      (SCH-ERROR "Non-numeric value -- COERCE-DOWNWARD" X))
  (IF (FLOATP X)
      (LET ((FX (FIX X)))
	(IF (= (FLOAT FX) X)
	    FX
	    X))
      X))

(DEFUN ASSOCIATE (L)
  (COND ((NULL L) NIL)
	(T (CONS (LIST (CAR L) (CADR L)) (ASSOCIATE (CDDR L))))))

(DEFUN UNION (S1 S2)
  (COND ((NULL S1) S2)
	((NULL S2) S1)
	((MEMQ (CAR S1) S2) (UNION (CDR S1) S2))
	(T (UNION (CDR S1) (CONS (CAR S1) S2)))))

(DEFUN SDIFF (S1 S2)
  (COND ((NULL S1) '())
	((NULL S2) S1)
	((MEMQ (CAR S1) S2) (SDIFF (CDR S1) S2))
	(T (CONS (CAR S1) (SDIFF (CDR S1) S2)))))

(DEFUN SDIFF! (S1 S2)
  (COND ((NULL S1) '())
	((NULL S2) S1)
	(T (SDIFF! (DELQ (CAR S2) S1) (CDR S2)))))

(DEFUN CHOP (N L)
  (REVERSE (NTHCDR N (REVERSE L))))

(DEFUN SET-HUNK (DEST SOURCE)
  (DO ((I 0. (1+ I)))
      ((= I (HUNKSIZE DEST)) DEST)
    (RPLACX I DEST (CXR I SOURCE))))

(DEFUN COPY-HUNK (SOURCE)
  (SET-HUNK (MAKHUNK (HUNKSIZE SOURCE)) SOURCE))


(DEFUN-IMPORT ATOM? (X)
  (NOT (PAIRP X)))

(DEFUN-IMPORT CONCAT N
  (LET ((L (LISTIFY N)))
    (COND ((< (LENGTH L) 2)
	   (CAR L))
	  (T
	   (IMPLODE (MAPCAN 'EXPLODEC L))))))



(DECLARE (SPECIAL *EXPRESSION))

(DEFUN-IMPORT LISP-EVAL (*EXPRESSION) (EVAL *EXPRESSION))

(ADD-TO-LISP-IMPORTS '(SYMEVAL NOT))