PDP-10.its/src/libmax/lmrun.43

;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(macsyma-module lmrun macro)

;; Lisp Machine compatibility package -- runtime

;; This file contains the run time end of the Lisp Machine compatibility
;; package in LIBMAX.  Many of the functions defined here are for use in
;; simulating string processing manipulating symbols.  The declarations for the
;; functions and globals defined here exist in LMRUND.

;; *** Currently, this file is used only on the PDP10 and in Franz.
;; *** NIL, LMLisp, and the extensions to Multics MacLisp define most
;; *** of these routines.  It is not used in Macsyma proper, but is
;; *** used by the display editor and other extensions.

(load-macsyma-macros lmrund)

;; List hacking functions.

(DEFUN BUTLAST (LIST)
  (CHECK-ARG LIST (OR (NULL LIST) (NOT (ATOM LIST))) "a list")
  (COND ((NULL LIST) NIL)
	(T (DO ((LIST LIST (CDR LIST))
		(NEW-LIST NIL (CONS (CAR LIST) NEW-LIST)))
	       ((NULL (CDR LIST)) (NREVERSE NEW-LIST))))))

(DEFUN NBUTLAST (LIST)
  (CHECK-ARG LIST (OR (NULL LIST) (NOT (ATOM LIST))) "a list")
  (COND ((NULL LIST) NIL)
	(T (DO ((LIST LIST (CDR LIST)))
	       ((NULL (CDDR LIST)) (RPLACD LIST NIL)))
	   LIST)))

(DEFUN FIRSTN (N LIST)
  (DECLARE (FIXNUM N))
  (CHECK-ARG N (AND (FIXP N) (>= N 0)) "a non-negative integer")
  (CHECK-ARG LIST (OR (NULL LIST) (NOT (ATOM LIST))) "a list")
  (DO ((OLD-LIST LIST (CDR OLD-LIST))
       (NEW-LIST NIL (CONS (CAR OLD-LIST) NEW-LIST))
       (COUNT N (1- COUNT)))
      ((OR (ZEROP COUNT) (NULL OLD-LIST)) (NREVERSE NEW-LIST))))

;; MEM works like MEMQ and MEMBER except that it can take an arbitrary
;; comparison predicate, i.e. (MEM 'EQ 3 LIST) = (MEMQ 3 LIST).

(DEFUN MEM (PREDICATE ELEMENT LIST)
  (CHECK-ARG LIST (OR (NULL LIST) (NOT (ATOM LIST))) "a list")
  (DO ((LIST LIST (CDR LIST)))
      ((NULL LIST) NIL)
    (IF (FUNCALL PREDICATE ELEMENT (CAR LIST)) (RETURN T))))

;; FIND-POSITION-IN-LIST looks down LIST for an element which is eq to OBJECT,
;; like MEMQ.  It reutrns the numeric index in the list at which it found the
;; first occurrence of OBJECT, or nil if it did not find it at all.
;; (find-position-in-list 'a '(a b c)) --> 0
;; (find-position-in-list 'e '(a b c)) --> nil

(DEFUN FIND-POSITION-IN-LIST (OBJECT LIST)
  (CHECK-ARG LIST (OR (NULL LIST) (NOT (ATOM LIST))) "a list")
  (DO ((L LIST (CDR L))
       (I 0 (1+ I)))
      ((NULL L) NIL)
    (DECLARE (FIXNUM I))
    (IF (EQ OBJECT (CAR L)) (RETURN I))))

;; Generalized ASSOC -- first argument is a comparison predicate which
;; is used instead of EQUAL.

(DEFUN ASS (PREDICATE ITEM ALIST)
  (CHECK-ARG ALIST (OR (NULL ALIST) (NOT (ATOM ALIST)))
	     "an association list")
  (DOLIST (PAIR ALIST)
    (IF (FUNCALL PREDICATE ITEM (CAR PAIR)) (RETURN PAIR))))

;; Reverse ASSQ -- like ASSQ but tries to find an element of the alist whose
;; cdr (not car) is EQ to the object.

(DEFUN RASSQ (ITEM ALIST)
  (CHECK-ARG ALIST (OR (NULL ALIST) (NOT (ATOM ALIST)))
	     "an association list")
  (DOLIST (PAIR ALIST)
    (IF (EQ ITEM (CDR PAIR)) (RETURN PAIR))))

;; Reverse ASSOC -- like ASSOC but tries to find an element of the alist
;; whose cdr (not car) is EQUAL to the object.

(DEFUN RASSOC (ITEM ALIST)
  (CHECK-ARG ALIST (OR (NULL ALIST) (NOT (ATOM ALIST)))
	     "an association list")
  (DOLIST (PAIR ALIST)
    (IF (EQUAL ITEM (CDR PAIR)) (RETURN PAIR)))))


;; Character and string manipulating functions.  The associated macros are in
;; LIBMAX;LMMAC.  Together, these two files implement a subset
;; of the  Lisp Machine string primitives.

;; Convert X into a character.

(DEFUN CHARACTER (X)
  (CASEQ (TYPEP X)
    (FIXNUM X)
    (SYMBOL (GETCHARN X 1))
    (T (FERROR ':WRONG-TYPE-ARGUMENT
	       "Cannot be coerced to a character -- ~S" X))))

;; Compare two characters ignoring case.  These have to be macros
;; rather than subrs since they are often applied.

(DEFUN CHAR-EQUAL (C1 C2)
  (DECLARE (FIXNUM C1 C2))
  (= (CHAR-UPCASE C1) (CHAR-UPCASE C2)))

(DEFUN CHAR-LESSP (C1 C2)
  (DECLARE (FIXNUM C1 C2))
  (< (CHAR-UPCASE C1) (CHAR-UPCASE C2)))

(DEFUN CHAR-UPCASE (C)
  (DECLARE (FIXNUM C))
  (IF (<= #/a C #/z) (BIT-CLEAR #O 40 C) C))

(DEFUN CHAR-DOWNCASE (C)
  (DECLARE (FIXNUM C))
  (IF (<= #/A C #/Z) (BIT-SET #O 40 C) C))

;; Should say (ASCII (LOGAND OBJECT #o 377)), but the ascii function only
;; looks at low order 8 bits anyway.

(DEFUN STRING (X)
  (CASEQ (TYPEP X)
    (SYMBOL (GET-PNAME X))
    (FIXNUM (GET-PNAME (ASCII X)))
    (T (FERROR ':WRONG-TYPE-ARGUMENT
	       "Cannot be coerced to a string -- ~S" X))))

;; The referencing mechanism for strings is zero based, i.e.  the zeroth
;; character refers to the first one and the n-1 th character is the last if
;; the string is n characters long.  The second argument is the initial
;; position from which to start building the substring, which continues up to
;; but not including the character specified by the third argument.  If the
;; third argument is not present, it defaults to the length of the string.
;; of resultant string.  If not given, build until end of string is reached.

(DEFUN SUBSTRING (STRING BEGIN &OPTIONAL (END NIL))
  (LET* ((EXPLODED-STRING (EXPLODEN STRING))
	 (LENGTH (LENGTH EXPLODED-STRING)))
    (IF (NOT END) (SETQ END LENGTH))
    (IF (OR (< BEGIN 0) (> BEGIN LENGTH))
	(FERROR ':WRONG-TYPE-ARGUMENT
		"Beginning subscript ~D out of range of string ~S"
		BEGIN STRING))
    (IF (OR (< END 0) (> END LENGTH))
	(FERROR ':WRONG-TYPE-ARGUMENT
		"Ending subscript ~D out of range of string ~S"
		END STRING))
    (MAKE-STRING-FROM-CHARS
     (FIRSTN (- END BEGIN) (NTHCDR BEGIN EXPLODED-STRING)))))

;; This is better as a function than as a macro since the arguments may be
;; either strings or characters.

(DEFUN STRING-APPEND (&REST STRINGS)
   (MAKE-STRING-FROM-CHARS
    (MAPCAN
     #'(LAMBDA (S)
         (COND ((SYMBOLP S) (EXPLODEN S))
	       ((FIXP S) (NCONS S))
	       (T (FERROR ':WRONG-TYPE-ARGUMENT
			  "Argument is not a string, symbol or character -- ~S"
			  S))))
     STRINGS))))

;; (DEFUN STRING-EQUAL (STRING-1 STRING-2 &OPTIONAL (BEGIN-1 0) (BEGIN-2 0)
;;                               (END-1 (STRING-LENGTH STRING-1))
;;                               (END-2 (STRING-LENGTH (STRING-2))))
;;        (STRING-EQUAL-2-ARGS (SUBSTRING STRING-1 BEGIN-1 END-1)
;;                             (SUBSTRING STRING-2 BEGIN-2 END-2)))

;; Compares two strings ignoring case.  Check to see if they are eq
;; as an efficiency hack.

(DEFUN STRING-EQUAL (STRING-1 STRING-2 &OPTIONAL (BEGIN-1 0) (BEGIN-2 0)
			      (END-1 NIL) (END-2 NIL))
  (COND ((EQ STRING-1 STRING-2) T)
	(T (SETQ STRING-1 (EXPLODEN STRING-1))
	   (SETQ STRING-2 (EXPLODEN STRING-2))
	   (LET ((LENGTH-1 (LENGTH STRING-1))
		 (LENGTH-2 (LENGTH STRING-2)))
	     (IF (NOT END-1) (SETQ END-1 LENGTH-1))
	     (IF (NOT END-2) (SETQ END-2 LENGTH-2))
	     (IF (= (- END-1 BEGIN-1) (- END-2 BEGIN-2))
		 ;; Strings are the same length
		 (DO ((STRING-1 (FIRSTN (- END-1 BEGIN-1) (NTHCDR BEGIN-1 STRING-1))
				(CDR STRING-1))
		      (STRING-2 (FIRSTN (- END-2 BEGIN-2) (NTHCDR BEGIN-2 STRING-2))
				(CDR STRING-2)))
		     ((NULL STRING-1) T)
		     (IF (NOT (CHAR-EQUAL (CAR STRING-1) (CAR STRING-2)))
			 (RETURN NIL))))))))

;; STRING-TRIM will return a substring of STRING with all characters in
;; CHAR-LIST stripped off the beginning and end.  STRING-LEFT-TRIM and
;; STRING-RIGHT-TRIM work similarly.

(SETQ WHITESPACE-CHAR-LIST '(#\TAB #\LF #\FORM #\RETURN #\SPACE))

(DEFUN STRING-TRIM (CHAR-LIST STRING)
       (STRING-LEFT-TRIM CHAR-LIST
                         (STRING-RIGHT-TRIM CHAR-LIST STRING)))

(DEFUN STRING-LEFT-TRIM (CHAR-LIST STRING)
  (CHECK-ARG CHAR-LIST (OR (NULL CHAR-LIST) (NOT (ATOM CHAR-LIST)))
	     "a list of characters")
  (COND ((NULL CHAR-LIST) STRING)
	(T (DO ((STRING (EXPLODEN STRING) (CDR STRING)))
	       ((NULL STRING) "")
	       (COND ((MEM 'CHAR-EQUAL (CAR STRING) CHAR-LIST))
		     (T (RETURN (MAKE-STRING-FROM-CHARS STRING))))))))

(DEFUN STRING-RIGHT-TRIM (CHAR-LIST STRING)
  (CHECK-ARG CHAR-LIST (OR (NULL CHAR-LIST) (NOT (ATOM CHAR-LIST)))
	     "a list of characters")
  (COND ((NULL CHAR-LIST) STRING)
	(T (DO ((STRING (NREVERSE (EXPLODEN STRING)) (CDR STRING)))
	       ((NULL STRING) "")
	       (COND ((MEM 'CHAR-EQUAL (CAR STRING) CHAR-LIST))
		     (T (RETURN (MAKE-STRING-FROM-CHARS (NREVERSE STRING)))))))))

;; Search for a substring within a string.  The search begins at BEGIN which
;; defaults to the beginning of the string.  The value returned is the index of
;; the first character of the first instance of KEY, or NIL if none is found.

(DEFUN STRING-SEARCH (KEY STRING &OPTIONAL (BEGIN 0))
  (DECLARE (FIXNUM BEGIN))
  (IF (> BEGIN (STRING-LENGTH STRING)) (LMRUN-INDEX-OUT-OF-RANGE BEGIN STRING))
  (SETQ KEY (EXPLODEN KEY))
  (LOOP FOR I FROM BEGIN
	FOR LIST ON (NTHCDR BEGIN (EXPLODEN STRING))
	WHEN (STRING-SEARCH-ALIGNED-SUBLIST KEY LIST) RETURN I))

(DEFUN STRING-SEARCH-ALIGNED-SUBLIST (KEY LIST)
  (DO ((LIST LIST (CDR LIST))
       (KEY KEY (CDR KEY)))
      ((NULL KEY) T)
      (COND ((NULL LIST) (RETURN NIL))
	    ((NOT (CHAR-EQUAL (CAR LIST) (CAR KEY))) (RETURN NIL)))))

;; Search for a character within a string.  The search begins at BEGIN and
;; defaults to the beginning of the string.

(DEFUN STRING-SEARCH-CHAR
       (CHAR STRING &OPTIONAL (BEGIN 0) &AUX (LENGTH (STRING-LENGTH STRING)))
  (DECLARE (FIXNUM CHAR BEGIN))
  (IF (> BEGIN LENGTH) (LMRUN-INDEX-OUT-OF-RANGE BEGIN STRING))
  (LOOP FOR I FROM BEGIN TO LENGTH
	WHEN (CHAR-EQUAL CHAR (GETCHARN STRING (1+ I))) RETURN I))

;; Search for any character within a string except a specific one.  The
;; search begins a BEGIN and defaults to the beginning of the string.

(DEFUN STRING-SEARCH-NOT-CHAR
       (CHAR STRING &OPTIONAL (BEGIN 0) &AUX (LENGTH (STRING-LENGTH STRING)))
  (DECLARE (FIXNUM CHAR BEGIN))
  (IF (> BEGIN LENGTH) (LMRUN-INDEX-OUT-OF-RANGE BEGIN STRING))
  (LOOP FOR I FROM BEGIN TO LENGTH
	UNLESS (CHAR-EQUAL CHAR (GETCHARN STRING (1+ I))) RETURN I))

(DEFUN LMRUN-INDEX-OUT-OF-RANGE (INDEX STRING)
  (FERROR ':WRONG-TYPE-ARGUMENT
	  "Index ~D out of range of string ~S" INDEX STRING))


;; User interaction -- mostly quick and dirty hacks.  Should flush
;; this and convert to LSPSRC;YESNOP.

(DEFVAR STANDARD-OUTPUT TYO)
(DEFVAR STANDARD-INPUT TYI)

;; Should really make an sfa which binds together tyi and tyo, since one
;; can't tyi from tyo.
(DEFVAR QUERY-IO TYO)

;; This really should take its arguments just as FORMAT does, and directly call
;; FORMAT.

(DEFUN YES-OR-NO-P (&OPTIONAL (MESSAGE NIL M-P) (STREAM QUERY-IO))
  (IF M-P (PRINC MESSAGE STREAM))
  ;; Kludge
  (DO ((RESPONSE (READLINE TYI) (READLINE TYI)))
      (NIL)
      (SETQ RESPONSE
	    (READ-FROM-STRING (STRING-TRIM WHITESPACE-CHAR-LIST RESPONSE)))
      (CASEQ RESPONSE
	((YES T CAIN HAI JA) (RETURN T))
	((NO NIL LO IE NYET) (RETURN NIL))
	(T (PRINC "(Yes or No) " STREAM)))))

;; Quick kludge to make Y-OR-N-P work.  Maybe we want to make MacLisp
;; streams look more like the LISPM's.

(DEFMACRO WITHOUT-ECHOING (&REST FORMS)
  `(LET ((STATUS-TTY (STATUS TTY)))
     (UNWIND-PROTECT
       (PROGN (SSTATUS TTY
		       (LOGAND (CAR STATUS-TTY) #O 070707070707)
		       (LOGAND (CADR STATUS-TTY) #O 070707070707))
	      . ,FORMS)
       (SSTATUS TTY (CAR STATUS-TTY) (CADR STATUS-TTY)))))

(DEFUN Y-OR-N-P (&OPTIONAL (MESSAGE NIL M-P) (STREAM QUERY-IO))
       (IF M-P (PRINC MESSAGE STREAM))
       (WITHOUT-ECHOING
	(DO ((RESPONSE (TYI TYI) (TYI TYI)))
	    (NIL)
	    (SETQ RESPONSE (CHAR-UPCASE RESPONSE))
	    (CASEQ RESPONSE
		   ((#/Y #/T #\SP) (PRINC "Yes." STREAM) (RETURN T))
		   ((#/N #\RUBOUT) (PRINC "No." STREAM) (RETURN NIL))
		   (T (PRINC " (Y or N) " STREAM))))))

(PUTPROP 'LMRUN 'VERSION T)