mirror of
https://github.com/PDP-10/its.git
synced 2026-02-17 13:17:18 +00:00
43 lines
1.4 KiB
Common Lisp
Executable File
43 lines
1.4 KiB
Common Lisp
Executable File
; -*-LISP-*-
|
|
; Find all atoms in the current obarray whose PNAME's contain a given string.
|
|
; TWAs (truly worthless atoms) are ignored unless value of APROPOS is non-null.
|
|
; Example: (APROPOS 'CHAR) returns
|
|
; (CHARPOS GETCHAR GETCHARN)
|
|
|
|
(DECLARE (SPECIAL APROPOS))
|
|
|
|
(OR (BOUNDP 'APROPOS) (SETQ APROPOS () ))
|
|
|
|
(DEFUN APROPOS (ARG)
|
|
(DECLARE (FIXNUM I FIRSTI MAXFIRSTI NEXTFIRSTI CN))
|
|
(PROG (MATCHL LARG ANSL)
|
|
A (COND ((NOT (SYMBOLP ARG))
|
|
(SETQ ARG (ERROR '|Non-symbol - APROPOS| ARG 'WRNG-TYPE-ARG))
|
|
(GO A)))
|
|
(SETQ MATCHL (EXPLODEN ARG) LARG (LENGTH MATCHL))
|
|
(MAPATOMS
|
|
'(LAMBDA (SYM)
|
|
(COND ((OR APROPOS (BOUNDP SYM) (PLIST SYM)) ;Test if not TWA
|
|
(DO ((FIRSTI 1 NEXTFIRSTI) ;First index for scanning
|
|
(MAXFIRSTI (- (FLATC SYM) LARG -1))
|
|
(NEXTFIRSTI 0)
|
|
(CN 0))
|
|
((> FIRSTI MAXFIRSTI) () )
|
|
(SETQ NEXTFIRSTI (1+ FIRSTI))
|
|
(COND ((NOT (= (CAR MATCHL) (GETCHARN SYM FIRSTI))))
|
|
((DO ((I (1+ FIRSTI) (1+ I)) ;Found 1st char match
|
|
(NFI-FL)
|
|
(L (CDR MATCHL) (CDR L)))
|
|
((NULL L) 'T)
|
|
(SETQ CN (GETCHARN SYM I))
|
|
(AND (NULL NFI-FL) ;Accellerator for FIRSTI
|
|
(= (CAR MATCHL) CN)
|
|
(SETQ NEXTFIRSTI I NFI-FL T))
|
|
(AND (NOT (= (CAR L) CN)) (RETURN () )))
|
|
(PUSH SYM ANSL)
|
|
(RETURN 'T))))))))
|
|
(RETURN ANSL)))
|
|
|
|
(DEFUN APROPOS-SORTED (ATOM)
|
|
(SORT (APROPOS ATOM) (FUNCTION ALPHALESSP)))
|