(FILECREATED " 2-Feb-86 17:18:09" {DSK}<LISPFILES2>FINDDEFN.LSP;2 12955
changes to: (VARS FINDDEFNCOMS))
(* Copyright (c) 1986 by Quintus Computer Systems, Inc. All rights reserved.)
(PRETTYCOMPRINT FINDDEFNCOMS)
(RPAQQ FINDDEFNCOMS ((FNS QP.FIND.DEFINITION QP.FIND.DEFINITION.PART.TWO QP.FIND.MORE.DEFINITION
QP.FIND.PRED.BEGINNING QP.GET.ARITY.FROM.STRING QP.GET.CURSOR
QP.GET.NAME.ARITY.DEFAULT QP.GET.NAME.FROM.STRING QP.LOCATE.DEFINITION
QP.LOCATE.PREDICATE.FOR.FD QP.REMOVE.SPACES QP.SKIP.WHITE.SPACE)
(MACROS QP.CHAR.IS.WHITE.SPACE QP.CONVERT.NAME.ARITY.TO.NAME
QP.FD.GET.FILENAME QP.GET.USER.NAME.ARITY
QP.GET.USER.NAME.ARITY.NO.DEFAULT QP.NAME.INCLUDES.ARITY
QP.SKIP.OVER.CHAR.IN.PRED.HEAD QP.VALID.UPPER.CASE.CHAR)
(VARS (QP.FD.ORI.STREAM NIL)
(QP.FIND.DEFINITION.FILES NIL))
(ADDVARS (GLOBALVARS QP.FD.ORI.STREAM)
(GLOBALVARS QP.FIND.DEFINITION.FILES))))
(DEFINEQ
(QP.FIND.DEFINITION
(LAMBDA (STREAM)
(SETQ QP.FD.ORI.STREAM STREAM)
(CLEARW (fetch (TEXTOBJ PROMPTWINDOW) of (TEXTOBJ STREAM)))
(SETQ QP.FIND.DEFINITION.FILES NIL)
(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 (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 (SETQ USER.INPUT (QP.GET.USER.NAME.ARITY.NO.DEFAULT)))
(if (NOT (EQUAL USER.INPUT "NIL"))
then (SETQ P.NAME (QP.GET.NAME.FROM.STRING USER.INPUT))
(SETQ P.ARITY (QP.GET.ARITY.FROM.STRING USER.INPUT))
else (if (NOT DEFAULT.NAME.ARITY)
then (SETQ ABORT T)))
(CLEARW (fetch (TEXTOBJ PROMPTWINDOW) of (TEXTOBJ STREAM)))
(if (NOT ABORT)
then (QP.SEND.PROLOG (CONCAT "find←predicate1(('" P.NAME "')," P.ARITY
")"))
(TEDIT.PROMPTPRINT STREAM " finding definition ..." T)
else (TEDIT.PROMPTPRINT STREAM " find-definition canceled" T))))))
(QP.FIND.DEFINITION.PART.TWO
(LAMBDA (DATA.LIST)
(for FILENAME in QP.FIND.DEFINITION.SOURCE.FILES
do (LET* ((WORKING.FILENAME (OR (FULLNAME FILENAME (QUOTE OLD))
FILENAME))
(WORKING.STREAM (GETPROP WORKING.FILENAME (QUOTE STREAM))))
(if (NOT WORKING.STREAM)
then (QUINTUS.TEDIT FILENAME)
(SETQ WORKING.STREAM QP.CURRENT.TEXTSTREAM)
(PUTPROP WORKING.FILENAME (QUOTE STREAM)
WORKING.STREAM)
else (PROMPTPRINT " Revisiting: " FILENAME))
(QP.LOCATE.PREDICATE.FOR.FD DATA.LIST WORKING.STREAM)))))
(QP.FIND.MORE.DEFINITION
(LAMBDA (STREAM NAME ARITY ENVIRONMENT FD.SLASH.ARITY)
(LET ((FD.FILE.NAME (QP.FD.GET.FILENAME)))
(if (NOT FD.FILE.NAME)
then (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 (QP.LOCATE.DEFINITION STREAM NAME ARITY)))))
(QP.FIND.PRED.BEGINNING
(LAMBDA (STREAM)
(\SETUPGETCH (QP.GET.CURSOR STREAM)
(TEXTOBJ STREAM))
(LET ((CHAR (QP.GET.NEXT.CHAR STREAM)))
(SELCHARQ CHAR
(NIL NIL)
((SPACE TAB EOL)
(LET ((CHAR (QP.SKIP.WHITE.SPACE STREAM)))
(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))
(SETQ CHAR (\BIN STREAM))
(\BACKBIN STREAM))
(if (NOT (QP.VALID.UPPER.CASE.CHAR CHAR))
then T))))))
(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))))))))
(QP.GET.CURSOR
(LAMBDA (STREAM)
(LET ((SEL (TEDIT.GETSEL STREAM))
LEFT RIGHT)
(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)))))
(QP.GET.NAME.ARITY.DEFAULT
(LAMBDA (STREAM)
(LET ((CHAR (QP.GET.NEXT.CHAR STREAM)))
(if (NEQ CHAR (CHARCODE EOL))
then (LET ((FND.FLAG (QP.FIND.PRED.BEGINNING STREAM))
(ORI.POSITION (ADD1 (\TEXTGETFILEPTR STREAM))))
(if FND.FLAG
then (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 (APPEND (CAR (LASTN P.NAME
(SUB1 (LENGTH
ARITY.LIST))))
(LIST (PACKC (CDR ARITY.LIST)))))))
)))))
(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))))))
(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))))
else (SETQ STOP T)))
(if POS
then (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)))))
(QP.LOCATE.PREDICATE.FOR.FD
(LAMBDA (DATA.LIST WORKING.STREAM)
(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 (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))
(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 (CAR (fetch (TEXTOBJ \WINDOW)
of (TEXTOBJ WORKING.STREAM)))
(QUOTE PROCESS)))
else (TTY.PROCESS (FIND.PROCESS QP.PROLOG.NAME))))))
(QP.REMOVE.SPACES
(LAMBDA (STRING)
(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))))
(QP.SKIP.WHITE.SPACE
(LAMBDA (STREAM)
(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.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))))))))
(PUTPROPS QP.CONVERT.NAME.ARITY.TO.NAME MACRO
(**MACROARG** (LET ((NAME.ARITY (CAR (NTH **MACROARG** 1))))
(BQUOTE (PROGN (PACKC (CAR (LASTN (\, NAME.ARITY)
2))))))))
(PUTPROPS QP.FD.GET.FILENAME MACRO (**MACROARG** (LET NIL (BQUOTE (PROGN (LET ((ANS (CAR
QP.FIND.DEFINITION.SOURCE.FILES)))
(SETQ
QP.FIND.DEFINITION.SOURCE.FILES
(CDR
QP.FIND.DEFINITION.SOURCE.FILES))
ANS))))))
(PUTPROPS QP.GET.USER.NAME.ARITY MACRO
(**MACROARG** (LET ((NAME (CAR (NTH **MACROARG** 1)))
(ARITY (CAR (NTH **MACROARG** 2))))
(BQUOTE (PROGN (QP.REMOVE.SPACES (TEDIT.GETINPUT
(TEXTOBJ STREAM)
(CONCATLIST (LIST "<return> to find "
(\, NAME)
"/"
(\, ARITY)
", or enter name/arity = ")))))
))))
(PUTPROPS QP.GET.USER.NAME.ARITY.NO.DEFAULT MACRO
(**MACROARG** (LET NIL (BQUOTE (PROGN (QP.REMOVE.SPACES (TEDIT.GETINPUT (TEXTOBJ STREAM)
"name/arity = ")))))
))
(PUTPROPS QP.NAME.INCLUDES.ARITY MACRO (**MACROARG** (LET ((NAME (CAR (NTH **MACROARG** 1))))
(BQUOTE (PROGN (MEMB (CHARCODE /)
(\, NAME)))))))
(PUTPROPS QP.SKIP.OVER.CHAR.IN.PRED.HEAD MACRO
(**MACROARG** (LET ((CHAR (CAR (NTH **MACROARG** 1))))
(BQUOTE (PROGN (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 {))))))))
(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))))))))
)
(RPAQQ QP.FD.ORI.STREAM NIL)
(RPAQQ QP.FIND.DEFINITION.FILES NIL)
(ADDTOVAR GLOBALVARS QP.FD.ORI.STREAM)
(ADDTOVAR GLOBALVARS QP.FIND.DEFINITION.FILES)
(PUTPROPS FINDDEFN.LSP COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (986 10403 (QP.FIND.DEFINITION 996 . 2499) (QP.FIND.DEFINITION.PART.TWO 2501 . 3153) (
QP.FIND.MORE.DEFINITION 3155 . 3847) (QP.FIND.PRED.BEGINNING 3849 . 4863) (QP.GET.ARITY.FROM.STRING
4865 . 5245) (QP.GET.CURSOR 5247 . 5587) (QP.GET.NAME.ARITY.DEFAULT 5589 . 6605) (
QP.GET.NAME.FROM.STRING 6607 . 6845) (QP.LOCATE.DEFINITION 6847 . 7895) (QP.LOCATE.PREDICATE.FOR.FD
7897 . 9780) (QP.REMOVE.SPACES 9782 . 10115) (QP.SKIP.WHITE.SPACE 10117 . 10401)))))
STOP