(FILECREATED " 8-Feb-86 15:22:57" {DSK}<LISPFILES2>IMPROVEDDCOMS>FINDDEFN.;1 12941
previous date: " 3-Feb-86 00:06:54" {GOEDEL}<usr2/pds/updating/lisp>FINDDEFN)
(* Copyright (c) 1986 by Quintus Computer Systems, Inc. All rights reserved.)
(PRETTYCOMPRINT FINDDEFNCOMS)
(RPAQQ FINDDEFNCOMS ((SCCS) (* WARNING: This material is CONFIDENTIAL and proprietary to Quintus
Computer Systems Inc.) (* Find-definition: Pre-Prolog call stage - gather the predicate name and arity
from the cursor position and a user prompt.) (FNS QP.GET.CURSOR) (MACROS QP.VALID.UPPER.CASE.CHAR
QP.CHAR.IS.WHITE.SPACE) (FNS QP.SKIP.WHITE.SPACE) (MACROS QP.SKIP.OVER.CHAR.IN.PRED.HEAD) (FNS
QP.FIND.PRED.BEGINNING) (MACROS QP.NAME.INCLUDES.ARITY) (FNS QP.GET.NAME.ARITY.DEFAULT) (MACROS
QP.CONVERT.NAME.ARITY.TO.NAME) (FNS QP.REMOVE.SPACES) (MACROS QP.GET.USER.NAME.ARITY) (MACROS
QP.GET.USER.NAME.ARITY.NO.DEFAULT) (FNS QP.GET.NAME.FROM.STRING) (FNS QP.GET.ARITY.FROM.STRING) (FNS
QP.FIND.DEFINITION) (* Find-definition: Post-Prolog call stage: display the file that the predicate
was defined in and show the definition.) (* Note that the global variable
QP.FIND.DEFINITION.SOURCE.FILES holds the list of files to be visited for the predicate definitions
for find.definition.part.two. It is declared global in the file TELLEDITOR.LSP) (FNS
QP.FIND.DEFINITION.PART.TWO) (FNS QP.LOCATE.PREDICATE.FOR.FD) (MACROS QP.FD.GET.FILENAME) (*
fd-get-filename takes the filenames off the top/front of the list and then removes the filename from
the list. The original file insertion mechanism in &fd-insert inserts the file names at the bottom/end
of the list. QP.FD.FILE adds filenames to the end of the list stored in
QP.FIND.DEFINITION.SOURCE.FILES) (FNS QP.FIND.MORE.DEFINITION) (FNS QP.LOCATE.DEFINITION)))
(* %%G% %%W% )
(* WARNING: This material is CONFIDENTIAL and proprietary to Quintus Computer Systems Inc.)
(* Find-definition: Pre-Prolog call stage - gather the predicate name and arity from the
cursor position and a user prompt.)
(DEFINEQ
(QP.GET.CURSOR
(LAMBDA (STREAM) (* pds: "20-Jan-86 11:07") (LET ((SEL (TEDIT.GETSEL STREAM))) (SELECTQ (fetch (
SELECTION POINT) of SEL) (LEFT (fetch (SELECTION CH#) of SEL)) (RIGHT (IDIFFERENCE (fetch (SELECTION
CHLIM) of SEL) 1)) (fetch (SELECTION CH#) of SEL)))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS QP.VALID.UPPER.CASE.CHAR MACRO (**MACROARG** (LET ((CHAR (CAR (NTH **MACROARG** 1)))) (
BQUOTE (PROGN (AND (IGEQ (\, CHAR) (CHARCODE A)) (ILEQ (\, CHAR) (CHARCODE Z))))))))
(PUTPROPS QP.CHAR.IS.WHITE.SPACE MACRO (**MACROARG** (LET ((CHAR (CAR (NTH **MACROARG** 1)))) (BQUOTE
(PROGN (OR (EQ (\, CHAR) (CHARCODE SPACE)) (EQ (\, CHAR) (CHARCODE TAB)) (EQ (\, CHAR) (CHARCODE EOL))
))))))
)
(DEFINEQ
(QP.SKIP.WHITE.SPACE
(LAMBDA (STREAM) (* This routine will return either the next non-white-space character, or nil if it
found the EOF first.) (LET ((CHAR (QP.GET.NEXT.CHAR STREAM))) (while (AND (NOT (NULL CHAR)) (
QP.CHAR.IS.WHITE.SPACE CHAR)) do (SETQ CHAR (QP.GET.NEXT.CHAR STREAM))) (\BACKBIN STREAM) CHAR)))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS QP.SKIP.OVER.CHAR.IN.PRED.HEAD MACRO ((CHAR) (OR (EQ CHAR (CHARCODE SPACE)) (EQ CHAR (
CHARCODE TAB)) (EQ CHAR (CHARCODE EOL)) (EQ CHAR 44) (EQ CHAR (CHARCODE %;)) (EQ CHAR (CHARCODE %()) (
EQ CHAR (CHARCODE >)) (EQ CHAR (CHARCODE %[)) (EQ CHAR (CHARCODE {)))))
)
(DEFINEQ
(QP.FIND.PRED.BEGINNING
(LAMBDA (STREAM) (* pds: " 2-Feb-86 23:30") (* 1st make sure the file pointer is where the cursor is:)
(\SETUPGETCH (QP.GET.CURSOR STREAM) (TEXTOBJ STREAM)) (LET ((CHAR (QP.GET.NEXT.CHAR STREAM))) (
SELCHARQ CHAR (NIL NIL) (* No character) ((SPACE TAB EOL) (* The routine started in white-space) (LET
((CHAR (QP.SKIP.WHITE.SPACE STREAM))) (* not at EOF, not at EOL, not a variable) (AND (NOT (NULL CHAR)
) (NOT (EQ CHAR (CHARCODE EOL))) (NOT (QP.VALID.UPPER.CASE.CHAR CHAR))))) (LET ((POSITION (
\TEXTGETFILEPTR STREAM)) (BACKMODE NIL)) (while (AND (NEQ POSITION 0) (NOT (
QP.SKIP.OVER.CHAR.IN.PRED.HEAD CHAR))) do (SETQ CHAR (\BACKBIN STREAM)) (SETQ POSITION (SUB1 POSITION)
) (SETQ BACKMODE T)) (if (QP.SKIP.OVER.CHAR.IN.PRED.HEAD CHAR) then (if BACKMODE then (\BIN STREAM) (*
Now at first valid character)) (SETQ CHAR (\BIN STREAM)) (\BACKBIN STREAM)) (if (NOT (
QP.VALID.UPPER.CASE.CHAR CHAR)) then T))))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS QP.NAME.INCLUDES.ARITY MACRO (**MACROARG** (LET ((NAME (CAR (NTH **MACROARG** 1)))) (BQUOTE
(PROGN (MEMB (CHARCODE /) (\, NAME)))))))
)
(DEFINEQ
(QP.GET.NAME.ARITY.DEFAULT
(LAMBDA (STREAM) (* pds: "20-Jan-86 12:13") (* This returns a list consisting of the character codes
that represent the predicate name followed by the character code for a "/" followed by the arity
number (not character code)) (LET ((CHAR (QP.GET.NEXT.CHAR STREAM))) (* see FINDPRED.LSP for source) (
if (NEQ CHAR (CHARCODE EOL)) then (* a default value was attempted) (LET ((FND.FLAG (
QP.FIND.PRED.BEGINNING STREAM)) (ORI.POSITION (ADD1 (\TEXTGETFILEPTR STREAM)))) (if FND.FLAG then (*
now at the beginning of the name) (* see FINDPRED.LSP for source of QP.GET.PRED.NAME) (LET* ((P.NAME (
QP.GET.PRED.NAME STREAM)) (ARITY.LIST (QP.NAME.INCLUDES.ARITY P.NAME))) (if (NOT ARITY.LIST) then (
\BACKBIN STREAM) (LET ((P.ARITY (QP.FIND.ARITY.AUX STREAM (TEXTOBJ STREAM) ORI.POSITION))) (if (AND
P.NAME P.ARITY) then (APPEND P.NAME (LIST (CHARCODE /) P.ARITY)))) else (* P.NAME includes arity but
as char codes) (* convert the arity char codes) (APPEND (CAR (LASTN P.NAME (SUB1 (LENGTH ARITY.LIST)))
) (LIST (PACKC (CDR ARITY.LIST))))))))))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS QP.CONVERT.NAME.ARITY.TO.NAME MACRO (**MACROARG** (LET ((NAME.ARITY (CAR (NTH **MACROARG** 1
)))) (BQUOTE (PROGN (PACKC (CAR (LASTN (\, NAME.ARITY) 2))))))))
)
(DEFINEQ
(QP.REMOVE.SPACES
(LAMBDA (STRING) (* This trick taken from TEDIT source file TEDITWINDOW It removes the leading and
trailing blanks) (LET ((FIRSTNONSPACE (STRPOSL (QUOTE (% )) STRING NIL T)) (LASTNONSPACE (STRPOSL (
QUOTE (% )) STRING NIL T T))) (if (AND FIRSTNONSPACE LASTNONSPACE) then (SUBSTRING STRING
FIRSTNONSPACE LASTNONSPACE) else STRING))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS QP.GET.USER.NAME.ARITY MACRO (**MACROARG** (LET ((NAME (CAR (NTH **MACROARG** 1))) (ARITY (
CAR (NTH **MACROARG** 2)))) (BQUOTE (QP.REMOVE.SPACES (TEDIT.GETINPUT (TEXTOBJ STREAM) "name/arity = "
(CONCAT (\, NAME) "/" (\, ARITY))))))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS QP.GET.USER.NAME.ARITY.NO.DEFAULT MACRO (**MACROARG** (LET NIL (BQUOTE (QP.REMOVE.SPACES (
TEDIT.GETINPUT (TEXTOBJ STREAM) "name/arity = "))))))
)
(DEFINEQ
(QP.GET.NAME.FROM.STRING
(LAMBDA (STRING) (LET ((SLASH.POSITION (STRPOS "/" STRING 1))) (SELECTQ SLASH.POSITION (1 "no←name") (
NIL STRING) (SUBSTRING STRING 1 (SUB1 SLASH.POSITION))))))
)
(DEFINEQ
(QP.GET.ARITY.FROM.STRING
(LAMBDA (STRING) (LET ((SLASH.POSITION (STRPOS "/" STRING 1)) (STRING.LENGTH (NCHARS STRING))) (if (OR
(NOT SLASH.POSITION) (EQ SLASH.POSITION STRING.LENGTH)) then "No←arity" else (PACK (UNPACK (SUBSTRING
STRING (ADD1 SLASH.POSITION) (NCHARS STRING))))))))
)
(DEFINEQ
(QP.FIND.DEFINITION
(LAMBDA (STREAM) (* pds: " 1-Feb-86 15:32") (SETQ QP.FD.ORI.STREAM STREAM) (CLEARW (fetch (TEXTOBJ
PROMPTWINDOW) of (TEXTOBJ STREAM))) (QP.CLEAR.FD.BUFFER) (if (QP.NOT.SAFE.TO.LOAD.CODE) then (
TEDIT.PROMPTPRINT STREAM "cannot use find-definition unless Prolog is at top-level" T) else (LET ((
DEFAULT.NAME.ARITY (QP.GET.NAME.ARITY.DEFAULT STREAM)) (ABORT NIL) USER.INPUT P.NAME P.ARITY) (if
DEFAULT.NAME.ARITY then (* a default was found) (SETQ P.ARITY (CAR (LAST DEFAULT.NAME.ARITY))) (SETQ
P.NAME (QP.CONVERT.NAME.ARITY.TO.NAME DEFAULT.NAME.ARITY)) (SETQ USER.INPUT (QP.GET.USER.NAME.ARITY
P.NAME P.ARITY)) else (* no default was found) (SETQ USER.INPUT (QP.GET.USER.NAME.ARITY.NO.DEFAULT)))
(if (NOT (EQUAL USER.INPUT "NIL")) then (* process any user input) (* There was user input) (SETQ
P.NAME (QP.GET.NAME.FROM.STRING USER.INPUT)) (SETQ P.ARITY (QP.GET.ARITY.FROM.STRING USER.INPUT)) else
(* There was no user input) (if (NOT DEFAULT.NAME.ARITY) then (SETQ ABORT T))) (CLEARW (fetch (
TEXTOBJ PROMPTWINDOW) of (TEXTOBJ STREAM))) (if (NOT ABORT) then (* see QPROCESS.LSP for the
definition of QP.SEND.PROLOG) (QP.SEND.PROLOG (CONCAT "find←predicate1(('" P.NAME "')," P.ARITY ")"))
(TEDIT.PROMPTPRINT STREAM " finding definition ..." T) else (TEDIT.PROMPTPRINT STREAM
" find-definition canceled" T))))))
)
(* Find-definition: Post-Prolog call stage: display the file that the predicate was defined in
and show the definition.)
(* Note that the global variable QP.FIND.DEFINITION.SOURCE.FILES holds the list of files to be
visited for the predicate definitions for find.definition.part.two. It is declared global in
the file TELLEDITOR.LSP)
(DEFINEQ
(QP.FIND.DEFINITION.PART.TWO
(LAMBDA (DATA.LIST) (* pds: " 2-Feb-86 20:25") (if QP.FIND.DEFINITION.SOURCE.FILES then (for FILENAME
in QP.FIND.DEFINITION.SOURCE.FILES do (LET ((WORKING.STREAM (QP.TEXTSTREAM FILENAME))) (if (NOT
WORKING.STREAM) then (* no open stream.) (QP.LOCATE.PREDICATE.FOR.FD DATA.LIST (TEXTSTREAM (TEDIT
FILENAME NIL NIL (QUOTE (TEDIT.MODE Prolog))))) elseif (NOT (QP.TEDIT.WINDOW FILENAME)) then (
TEDIT.PROMPTPRINT QP.FD.ORI.STREAM (CONCAT (CAR DATA.LIST) "/" (CADR DATA.LIST) " has been lost") T)
else (PROMPTPRINT " Revisiting: " FILENAME) (QP.LOCATE.PREDICATE.FOR.FD DATA.LIST WORKING.STREAM))))
else (TEDIT.PROMPTPRINT QP.FD.ORI.STREAM (CONCAT (CAR DATA.LIST) "/" (CADR DATA.LIST) " not found") T
))))
)
(DEFINEQ
(QP.LOCATE.PREDICATE.FOR.FD
(LAMBDA (DATA.LIST WORKING.STREAM) (* pds: " 1-Feb-86 16:08") (LET* ((P.NAME (CAR DATA.LIST)) (P.ARITY
(CADR DATA.LIST)) (FLAG (CADDR DATA.LIST)) (ENVIRONMENT (CADDDR DATA.LIST)) (FD.SLASH.ARITY (if (
EQUAL P.ARITY (QUOTE ←)) then "" else (CONCAT "/" P.ARITY)))) (CLEARW (fetch (TEXTOBJ PROMPTWINDOW) of
(TEXTOBJ WORKING.STREAM))) (if (EQ (QUOTE built←in) FLAG) then (TEDIT.PROMPTPRINT WORKING.STREAM (
CONCAT P.NAME FD.SLASH.ARITY " is a built-in predicate") T) elseif (EQ (QUOTE undefined) FLAG) then (
TEDIT.PROMPTPRINT WORKING.STREAM (CONCAT P.NAME FD.SLASH.ARITY " is undefined") T) elseif (EQ (QUOTE
none) FLAG) then (TEDIT.PROMPTPRINT WORKING.STREAM (CONCAT "no file associated with " P.NAME
FD.SLASH.ARITY) T) elseif (EQ (QUOTE ok) FLAG) then (if (EQUAL P.NAME "") then (* No Pred Name) (
TEDIT.PROMPTPRINT WORKING.STREAM "you must use find-definition first" T) else (QP.FIND.MORE.DEFINITION
WORKING.STREAM P.NAME P.ARITY ENVIRONMENT FD.SLASH.ARITY)) else (TEDIT.PROMPTPRINT WORKING.STREAM (
CONCAT "find definition error = " FLAG) T)) (* Last transfer control to the editor window if calling
from the editor) (if QP.FD.ORI.STREAM then (TEDIT.PROMPTPRINT QP.FD.ORI.STREAM " " T) (SETQ
QP.FD.ORI.STREAM NIL)) (if (EQ ENVIRONMENT (QUOTE ed)) then (TTY.PROCESS (WINDOWPROP (QP.TEDIT.WINDOW
WORKING.STREAM) (QUOTE PROCESS))) else (TTY.PROCESS (FIND.PROCESS QP.PROLOG.NAME))))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS QP.FD.GET.FILENAME MACRO (NIL (pop QP.FIND.DEFINITION.SOURCE.FILES)))
)
(* fd-get-filename takes the filenames off the top/front of the list and then removes the
filename from the list. The original file insertion mechanism in &fd-insert inserts the file
names at the bottom/end of the list. QP.FD.FILE adds filenames to the end of the list stored in
QP.FIND.DEFINITION.SOURCE.FILES)
(DEFINEQ
(QP.FIND.MORE.DEFINITION
(LAMBDA (STREAM NAME ARITY ENVIRONMENT FD.SLASH.ARITY) (* pds: "20-Jan-86 15:05") (LET ((FD.FILE.NAME
(QP.FD.GET.FILENAME))) (if (NOT FD.FILE.NAME) then (* filename is a null string) (SETQ
QP.FIND.DEFINITION.SOURCE.FILES NIL) (TEDIT.PROMPTPRINT STREAM (CONCAT "no more source files for "
NAME FD.SLASH.ARITY) T) elseif (EQUAL "user" FD.FILE.NAME) then (TEDIT.PROMPTPRINT STREAM (CONCAT NAME
FD.SLASH.ARITY "was defined from user" (if QP.FIND.DEFINITION.SOURCE.FILES then
" - type %"↑X,%" for more" else "")) T) else (* we must have a valid filename) (* need an if statement
on the environment = "debug" case) (QP.LOCATE.DEFINITION STREAM NAME ARITY)))))
)
(DEFINEQ
(QP.LOCATE.DEFINITION
(LAMBDA (STREAM NAME ARITY) (LET ((STOP NIL) (TEXT (TEXTOBJ STREAM)) (START 1) (POS (TEDIT.FIND STREAM
NAME 1))) (while (AND POS (NOT STOP)) do (if POS then (\SETUPGETCH POS TEXT) (if (EQ (QP.FIND.ARITY
STREAM NAME) ARITY) then (SETQ STOP T) else (SETQ START (ADD1 POS)) (SETQ POS (TEDIT.FIND STREAM (
CONCAT (CHARACTER (CHARCODE CR)) NAME) START)) (if POS then (SETQ POS (ADD1 POS))) (* skip the CR))
else (SETQ STOP T))) (if POS then (* found it) (LET ((SELECTION (TEDIT.SETSEL STREAM POS 1 (QUOTE LEFT
)))) (TEDIT.NORMALIZECARET TEXT SELECTION) (TEDIT.SETSEL STREAM SELECTION)) else (TEDIT.PROMPTPRINT
STREAM (CONCAT "cannot find " NAME "/" ARITY) T)))))
)
(PUTPROPS FINDDEFN COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2061 2344 (QP.GET.CURSOR 2071 . 2342)) (2767 3097 (QP.SKIP.WHITE.SPACE 2777 . 3095)) (
3396 4349 (QP.FIND.PRED.BEGINNING 3406 . 4347)) (4521 5606 (QP.GET.NAME.ARITY.DEFAULT 4531 . 5604)) (
5801 6169 (QP.REMOVE.SPACES 5811 . 6167)) (6623 6825 (QP.GET.NAME.FROM.STRING 6633 . 6823)) (6826 7126
(QP.GET.ARITY.FROM.STRING 6836 . 7124)) (7127 8481 (QP.FIND.DEFINITION 7137 . 8479)) (8835 9586 (
QP.FIND.DEFINITION.PART.TWO 8845 . 9584)) (9587 11020 (QP.LOCATE.PREDICATE.FOR.FD 9597 . 11018)) (
11450 12150 (QP.FIND.MORE.DEFINITION 11460 . 12148)) (12151 12850 (QP.LOCATE.DEFINITION 12161 . 12848)
))))
STOP