mirror of
https://github.com/PDP-10/its.git
synced 2026-01-31 05:52:12 +00:00
184 lines
5.5 KiB
Plaintext
Executable File
184 lines
5.5 KiB
Plaintext
Executable File
;;; -*- Mode:LISP; -*-
|
||
|
||
;;; FAKE-STRING: Package for manipulating fake strings as real strings
|
||
|
||
;;; `fake' string definitions for:
|
||
;;;
|
||
;;; (STRINGP obj) - Returns T if obj is a fake string.
|
||
;;; (CHARACTER s) - Coerces a string to a character.
|
||
;;; (CHAR-UPCASE c) - Uppercases a character.
|
||
;;; (CHAR-DOWNCASE c) - Lowercases a character.
|
||
;;; (STRING-UPCASE s) - Uppercases a string.
|
||
;;; (STRING-DOWNCASE s) - Lowercases a string.
|
||
;;; (STRING-APPEND s1 s2 ...) - Appends any number of strings together.
|
||
|
||
;;; Package created and maintained by KMP@MC
|
||
|
||
;;; (STRINGP x)
|
||
;;;
|
||
;;; Predicate returns true iff x is a fake string, otherwise returns false.
|
||
;;;
|
||
;;; Note: Because of the way Maclisp implements fake strings, SYMBOLP will
|
||
;;; also return true for fake strings. Hence, in any case where
|
||
;;; dispatching is being done on type, do the STRINGP check before the
|
||
;;; SYMBOLP check as in:
|
||
;;;
|
||
;;; (COND ...
|
||
;;; ((STRINGP x) ...) ;Check strings first
|
||
;;; ((SYMBOLP x) ...) ;Things that aren't STRINGP are `real' symbols
|
||
;;; ...)
|
||
|
||
(DEFUN STRINGP (X)
|
||
(AND (SYMBOLP X) (GET X '+INTERNAL-STRING-MARKER)))
|
||
|
||
;;; (STRING-EQUAL string1 string2)
|
||
;;;
|
||
;;; Predicate compares string1 and string2 returning true iff string1
|
||
;;; and string2 represent the same string. Case is not significant in
|
||
;;; comparisons.
|
||
|
||
(DEFUN STRING-EQUAL (S1 S2)
|
||
(IF (FIXP S1) (SETQ S1 (CHAR-UPCASE S1)))
|
||
(IF (FIXP S2) (SETQ S2 (CHAR-UPCASE S2)))
|
||
(COND ((FIXP S1)
|
||
(COND ((FIXP S2) (= S1 S2))
|
||
((SYMBOLP S2)
|
||
(LET ((PNAME (PNGET S2 7.)))
|
||
(AND (NULL (CDR PNAME))
|
||
(= (CAR PNAME) (LSH S1 #o35)))))
|
||
(T (ERROR "Not a string -- STRING-EQUAL" S2))))
|
||
((SYMBOLP S1)
|
||
(COND ((FIXP S2)
|
||
(LET ((PNAME (PNGET S1 7.)))
|
||
(AND (NULL (CDR PNAME))
|
||
(= (CAR PNAME) (LSH S2 #o35)))))
|
||
((SYMBOLP S2)
|
||
(DO ((L1 (PNGET S1 7.) (CDR L1))
|
||
(L2 (PNGET S2 7.) (CDR L2))
|
||
(CHAR1 0.) (CHAR2 0.))
|
||
((NULL L1) (NULL L2))
|
||
(DECLARE (FIXNUM CHAR1 CHAR2))
|
||
(IF (NULL L2) (RETURN NIL))
|
||
(LET ((W1 (FIXNUM-IDENTITY (CAR L1)))
|
||
(W2 (FIXNUM-IDENTITY (CAR L2))))
|
||
(DECLARE (FIXNUM W1 W2))
|
||
(IF (AND (NOT (= W1 W2))
|
||
(DO ((BP #o3507 (- BP #o700)))
|
||
((MINUSP BP) NIL)
|
||
(DECLARE (FIXNUM BP))
|
||
(IF (NOT (OR (< (SETQ CHAR1 (LDB BP W1)) #/a)
|
||
(> CHAR1 #/z)))
|
||
(SETQ CHAR1 (+ CHAR1 #.(- #/A #/a))))
|
||
(IF (NOT (OR (< (SETQ CHAR2 (LDB BP W2)) #/a)
|
||
(> CHAR2 #/z)))
|
||
(SETQ CHAR2 (+ CHAR2 #.(- #/A #/a))))
|
||
(IF (NOT (= CHAR1 CHAR2))
|
||
(RETURN T))))
|
||
(RETURN NIL)))))
|
||
(T (ERROR "Not a string -- STRING-EQUAL" S2))))
|
||
(T (ERROR "Not a string -- STRING-EQUAL" S1))))
|
||
|
||
|
||
|
||
|
||
;;; (CHARACTER x)
|
||
;;;
|
||
;;; Coerces x to be a character in fixnum representation.
|
||
;;; If x is a fixnum, it is returned.
|
||
;;; If x is a symbol, the first character of its pname is returned.
|
||
;;; If x is a fake string, its first character is returned.
|
||
|
||
(DEFUN CHARACTER (X)
|
||
(COND ((SYMBOLP X) (GETCHARN X 1.))
|
||
((FIXP X) X)
|
||
(T (ERROR "Not a string -- CHARACTER" X))))
|
||
|
||
;;; (STRING-APPEND string1 string2 string3 ...)
|
||
;;;
|
||
;;; Returns a string which is the concatenation of the given strings.
|
||
|
||
(DEFUN STRING-APPEND NARGS
|
||
(DECLARE (FIXNUM NARGS))
|
||
(DO ((STRING "" (COND ((FIXP (ARG I)) (FORMAT NIL "~A~C" STRING (ARG I)))
|
||
((SYMBOLP (ARG I)) (FORMAT NIL "~A~A" STRING (ARG I)))
|
||
(T (ERROR "Not a string -- STRING-APPEND" (ARG I)))))
|
||
(I 1 (1+ I)))
|
||
((> I NARGS) STRING)
|
||
(DECLARE (FIXNUM I))))
|
||
|
||
;;; (STRING-UPCASE string)
|
||
;;;
|
||
;;; Returns an uppercased copy of string.
|
||
|
||
(DEFUN STRING-UPCASE (STRING)
|
||
(DO ((L (+INTERNAL-GET-PNAME STRING 'STRING-UPCASE) (CDR L))
|
||
(NEW-L NIL))
|
||
((NULL L) (+INTERNAL-MAKE-STRING (NREVERSE NEW-L)))
|
||
(DO ((WORD (FIXNUM-IDENTITY (CAR L)))
|
||
(BP #o3507 (- BP #o700))
|
||
(NEW 0. (DPB CHAR BP NEW))
|
||
(CHAR 0.))
|
||
((MINUSP BP) (PUSH NEW NEW-L))
|
||
(DECLARE (FIXNUM WORD BP NEW CHAR))
|
||
(COND ((NOT (OR (< (SETQ CHAR (LDB BP WORD)) #/a) (> CHAR #/z)))
|
||
(SETQ CHAR (+ CHAR #.(- #/A #/a))))))))
|
||
|
||
;;; (STRING-DOWNCASE string)
|
||
;;;
|
||
;;; Returns a lowercased copy of string.
|
||
|
||
(DEFUN STRING-DOWNCASE (STRING)
|
||
(DO ((L (+INTERNAL-GET-PNAME STRING 'STRING-DOWNCASE) (CDR L))
|
||
(NEW-L NIL))
|
||
((NULL L) (+INTERNAL-MAKE-STRING (NREVERSE NEW-L)))
|
||
(DO ((WORD (FIXNUM-IDENTITY (CAR L)))
|
||
(BP #o3507 (- BP #o700))
|
||
(NEW 0. (DPB CHAR BP NEW))
|
||
(CHAR 0.))
|
||
((MINUSP BP) (PUSH NEW NEW-L))
|
||
(DECLARE (FIXNUM WORD BP NEW CHAR))
|
||
(COND ((NOT (OR (< (SETQ CHAR (LDB BP WORD)) #/A) (> CHAR #/Z)))
|
||
(SETQ CHAR (+ CHAR #.(- #/a #/A))))))))
|
||
|
||
|
||
;;; (CHAR-UPCASE C)
|
||
;;;
|
||
;;; Returns the character C in uppercase.
|
||
|
||
(DEFUN CHAR-UPCASE (C)
|
||
(COND ((NOT (FIXP C)) (ERROR "Not a character -- CHAR-UPCASE"))
|
||
((OR (< C #/a) (> C #/z)) C)
|
||
(T (+ C #.(- #/A #/a)))))
|
||
|
||
;;; (CHAR-DOWNCASE C)
|
||
;;;
|
||
;;; Returns the character C in lowercase.
|
||
|
||
(DEFUN CHAR-DOWNCASE (C)
|
||
(COND ((NOT (FIXP C)) (ERROR "Not a character -- CHAR-DOWNCASE"))
|
||
((OR (< C #/A) (> C #/Z)) C)
|
||
(T (+ C #.(- #/a #/A)))))
|
||
|
||
|
||
;;; Utility functions. Not for use by users.
|
||
|
||
;;; Takes a symbol, fake string, or fixnum and returns its pname.
|
||
|
||
(DEFUN +INTERNAL-GET-PNAME (STRING FN)
|
||
(COND ((SYMBOLP STRING) (PNGET STRING 7.))
|
||
((FIXP STRING) (NCONS (LSH STRING #o35)))
|
||
(T (ERROR "Not a string -- ~A" STRING FN))))
|
||
|
||
;;; Takes a pname and returns a fake string.
|
||
|
||
(DEFUN +INTERNAL-MAKE-STRING (PNAME)
|
||
(SETQ PNAME (PNPUT PNAME NIL))
|
||
(PUTPROP PNAME T '+INTERNAL-STRING-MARKER)
|
||
PNAME)
|
||
|
||
|
||
;;; Local Modes:;
|
||
;;; Mode:LISP;
|
||
;;; Lisp IF Indent:2;
|
||
;;; End:;
|
||
|