xref.lisp 123 KB
Newer Older
Helmut Eller's avatar
Helmut Eller committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
;;; -*- Mode: LISP; Package: XREF; Syntax: Common-lisp;  -*- 
;;; Mon Jan 21 16:21:20 1991 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU>
;;; xref.lisp

;;; ****************************************************************
;;; List Callers: A Static Analysis Cross Referencing Tool for Lisp 
;;; ****************************************************************
;;; 
;;; The List Callers system is a portable Common Lisp cross referencing
;;; utility. It grovels over a set of files and compiles a database of the
;;; locations of all references for each symbol used in the files.
;;; List Callers is similar to the Symbolics Who-Calls and the
;;; Xerox Masterscope facilities.
;;;
;;; When you change a function or variable definition, it can be useful
;;; to know its callers, in order to update each of them to the new
;;; definition. Similarly, having a graphic display of the structure 
;;; (e.g., call graph) of a program can help make undocumented code more
;;; understandable. This static code analyzer facilitates both capabilities.
;;; The database compiled by xref is suitable for viewing by a graphical 
;;; browser. (Note: the reference graph is not necessarily a DAG. Since many
;;; graphical browsers assume a DAG, this will lead to infinite loops.
;;; Some code which is useful in working around this problem is included,
;;; as well as a sample text-indenting outliner and an interface to Bates'
;;; PSGraph Postscript Graphing facility.) 
;;;
;;; Written by Mark Kantrowitz, July 1990.
;;;
;;; Address: School of Computer Science
;;;          Carnegie Mellon University
;;;          Pittsburgh, PA 15213
;;;
;;; Copyright (c) 1990. All rights reserved.
;;;
;;; See general license below.
;;;

;;; ****************************************************************
;;; General License Agreement and Lack of Warranty *****************
;;; ****************************************************************
;;;
;;; This software is distributed in the hope that it will be useful (both
;;; in and of itself and as an example of lisp programming), but WITHOUT
;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for
;;; the consequences of using it or for whether it serves any particular
;;; purpose or works at all. No warranty is made about the software or its
;;; performance. 
;;; 
;;; Use and copying of this software and the preparation of derivative
;;; works based on this software are permitted, so long as the following
;;; conditions are met:
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72
;;;	o  The copyright notice and this entire notice are included intact
;;;        and prominently carried on all copies and supporting documentation.
;;;	o  No fees or compensation are charged for use, copies, or
;;;	   access to this software. You may charge a nominal
;;;	   distribution fee for the physical act of transferring a
;;;	   copy, but you may not charge for the program itself. 
;;;	o  If you modify this software, you must cause the modified
;;;	   file(s) to carry prominent notices (a Change Log)
;;;	   describing the changes, who made the changes, and the date
;;;	   of those changes.
;;;	o  Any work distributed or published that in whole or in part
;;;	   contains or is a derivative of this software or any part 
;;;	   thereof is subject to the terms of this agreement. The 
;;;	   aggregation of another unrelated program with this software
;;;	   or its derivative on a volume of storage or distribution
;;;	   medium does not bring the other program under the scope
;;;	   of these terms.
;;;	o  Permission is granted to manufacturers and distributors of
;;;	   lisp compilers and interpreters to include this software
;;;	   with their distribution. 
;;;
Helmut Eller's avatar
Helmut Eller committed
73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
;;; This software is made available AS IS, and is distributed without 
;;; warranty of any kind, either expressed or implied.
;;; 
;;; In no event will the author(s) or their institutions be liable to you
;;; for damages, including lost profits, lost monies, or other special,
;;; incidental or consequential damages arising out of or in connection
;;; with the use or inability to use (including but not limited to loss of
;;; data or data being rendered inaccurate or losses sustained by third
;;; parties or a failure of the program to operate as documented) the 
;;; program, even if you have been advised of the possibility of such
;;; damanges, or for any claim by any other party, whether in an action of
;;; contract, negligence, or other tortious action.
;;; 
;;; The current version of this software and a variety of related utilities
;;; may be obtained by anonymous ftp from ftp.cs.cmu.edu in the directory
;;;    user/ai/lang/lisp/code/tools/xref/
;;; 
;;; Please send bug reports, comments, questions and suggestions to
;;; mkant@cs.cmu.edu. We would also appreciate receiving any changes
;;; or improvements you may make. 
;;; 
;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list, 
;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email
;;; address, and affiliation. This mailing list is primarily for
;;; notification about major updates, bug fixes, and additions to the lisp
;;; utilities collection. The mailing list is intended to have low traffic.
;;;

;;; ********************************
;;; Change Log *********************
;;; ********************************
;;;
;;; 27-FEB-91 mk   Added insert arg to psgraph-xref to allow the postscript
;;;                graphs to be inserted in Scribe documents.
;;; 21-FEB-91 mk   Added warning if not compiled.
;;; 07-FEB-91 mk   Fixed bug in record-callers with regard to forms at 
;;;                toplevel.
;;; 21-JAN-91 mk   Added file xref-test.lisp to test xref.
;;; 16-JAN-91 mk   Added definition WHO-CALLS to parallel the Symbolics syntax.
;;; 16-JAN-91 mk   Added macroexpansion capability to record-callers. Also
;;;                added parameter *handle-macro-forms*, defaulting to T.
;;; 16-JAN-91 mk   Modified print-caller-tree and related functions
;;;                to allow the user to specify root nodes. If the user
;;;                doesn't specify them, it will default to all root
;;;                nodes, as before. 
;;; 16-JAN-91 mk   Added parameter *default-graphing-mode* to specify
;;;                the direction of the graphing. Either :call-graph,
;;;                where the children of a node are those functions called
;;;                by the node, or :caller-graph where the children of a
;;;                node are the callers of the node. :call-graph is the
;;;                default.
;;; 16-JAN-91 mk   Added parameter *indent-amount* to control the indentation
;;;                in print-indented-tree.
;;; 16-JUL-90 mk   Functions with argument lists of () were being ignored
;;;                because of a (when form) wrapped around the body of
;;;                record-callers. Then intent of (when form) was as an extra
;;;                safeguard against infinite looping. This wasn't really
;;;                necessary, so it has been removed.
;;; 16-JUL-90 mk   PSGraph-XREF now has keyword arguments, instead of
;;;                optionals.
;;; 16-JUL-90 mk   Added PRINT-CLASS-HIERARCHY to use psgraph to graph the
;;;                CLOS class hierarchy. This really doesn't belong here,
;;;                and should be moved to psgraph.lisp as an example of how
;;;                to use psgraph.
;;; 16-JUL-90 mk   Fixed several caller patterns. The pattern for member
;;;                had an error which caused many references to be missed.
;;; 16-JUL-90 mk   Added ability to save/load processed databases.
;;;  5-JUL-91 mk    Fixed warning of needing compilation to occur only when the
;;;                 source is loaded.
;;; 20-SEP-93 mk    Added fix from Peter Norvig to allow Xref to xref itself.
;;;                 The arg to macro-function must be a symbol.
144
;;;  7-APR-12 heller  Break lines at 80 columns.
Helmut Eller's avatar
Helmut Eller committed
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592

;;; ********************************
;;; To Do **************************
;;; ********************************
;;;
;;; Verify that:
;;;    o  null forms don't cause it to infinite loop.
;;;    o  nil matches against null argument lists.
;;;    o  declarations and doc are being ignored.
;;;
;;; Would be nice if in addition to showing callers of a function, it
;;; displayed the context of the calls to the function (e.g., the
;;; immediately surrounding form). This entails storing entries of
;;; the form (symbol context*) in the database and augmenting
;;; record-callers to keep the context around. The only drawbacks is
;;; that it would cons a fair bit. If we do this, we should store
;;; additional information as well in the database, such as the caller
;;; pattern type (e.g., variable vs. function).
;;;
;;; Write a translator from BNF (at least as much of BNF as is used
;;; in CLtL2), to the format used here.
;;;
;;; Should automatically add new patterns for new functions and macros
;;; based on their arglists. Probably requires much more than this
;;; simple code walker, so there isn't much we can do.
;;;
;;; Defmacro is a problem, because it often hides internal function
;;; calls within backquote and quote, which we normally ignore. If
;;; we redefine QUOTE's pattern so that it treats the arg like a FORM,
;;; we'll probably get them (though maybe the syntax will be mangled),
;;; but most likely a lot of spurious things as well. 
;;;
;;; Define an operation for Defsystem which will run XREF-FILE on the
;;; files of the system. Or yet simpler, when XREF sees a LOAD form
;;; for which the argument is a string, tries to recursively call
;;; XREF-FILE on the specified file. Then one could just XREF-FILE
;;; the file which loads the system. (This should be a program
;;; parameter.)
;;;
;;; Have special keywords which the user may place in a file to have
;;; XREF-FILE ignore a region.
;;;
;;; Should we distinguish flet and labels from defun? I.e., note that
;;; flet's definitions are locally defined, instead of just lumping
;;; them in with regular definitions.
;;;
;;; Add patterns for series, loop macro.
;;;
;;; Need to integrate the variable reference database with the other
;;; databases, yet maintain separation. So we can distinguish all
;;; the different types of variable and function references, without
;;; multiplying databases.
;;;
;;; Would pay to comment record-callers and record-callers* in more
;;; depth.
;;; 
;;; (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT)

;;; ********************************
;;; Notes **************************
;;; ********************************
;;;
;;;    XREF has been tested (successfully) in the following lisps:
;;;       CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
;;;       Macintosh Allegro Common Lisp (1.3.2)
;;;       ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90)
;;;       Lucid CL (Version 2.1 6-DEC-87)
;;;    
;;;    XREF has been tested (unsuccessfully) in the following lisps:
;;;       Ibuki Common Lisp (01/01, October 15, 1987)
;;;           - if interpreted, runs into stack overflow
;;;           - does not compile (tried ibcl on Suns, PMAXes and RTs)
;;;             seems to be due to a limitation in the c compiler.
;;;    
;;;    XREF needs to be tested in the following lisps:
;;;       Symbolics Common Lisp (8.0)
;;;       Lucid Common Lisp (3.0, 4.0)
;;;       KCL (June 3, 1987 or later)
;;;       AKCL (1.86, June 30, 1987 or later)
;;;       TI (Release 4.1 or later)
;;;       Golden Common Lisp (3.1 IBM-PC)
;;;       VAXLisp (2.0, 3.1)
;;;       HP Common Lisp (same as Lucid?)
;;;       Procyon Common Lisp


;;; ****************************************************************
;;; Documentation **************************************************
;;; ****************************************************************
;;;
;;; XREF analyzes a user's program, determining which functions call a
;;; given function, and the location of where variables are bound/assigned
;;; and used. The user may retrieve this information for either a single
;;; symbol, or display the call graph of portions of the program
;;; (including the entire program). This allows the programmer to debug
;;; and document the program's structure.
;;; 
;;; XREF is primarily intended for analyzing large programs, where it is
;;; difficult, if not impossible, for the programmer to grasp the structure
;;; of the whole program. Nothing precludes using XREF for smaller programs,
;;; where it can be useful for inspecting the relationships between pieces
;;; of the program and for documenting the program.
;;; 
;;; Two aspects of the Lisp programming language greatly simplify the
;;; analysis of Lisp programs:
;;; 	o  Lisp programs are naturally represented as data.
;;; 	   Successive definitions from a file are easily read in
;;; 	   as list structure.
;;; 	o  The basic syntax of Lisp is uniform. A list program
;;; 	   consists of a set of nested forms, where each form is
;;; 	   a list whose car is a tag (e.g., function name) that
;;; 	   specifies the structure of the rest of the form.
;;; Thus Lisp programs, when represented as data, can be considered to be
;;; parse trees. Given a grammar of syntax patterns for the language, XREF
;;; recursively descends the parse tree for a given definition, computing
;;; a set of relations that hold for the definition at each node in the
;;; tree. For example, one kind of relation is that the function defined
;;; by the definition calls the functions in its body. The relations are
;;; stored in a database for later examination by the user.
;;; 
;;; While XREF currently only works for programs written in Lisp, it could
;;; be extended to other programming languages by writing a function to
;;; generate parse trees for definitions in that language, and a core
;;; set of patterns for the language's syntax.
;;; 
;;; Since XREF normally does a static syntactic analysis of the program, 
;;; it does not detect references due to the expansion of a macro definition. 
;;; To do this in full generality XREF would have to have knowledge about the
;;; semantics of the program (e.g., macros which call other functions to
;;; do the expansion). This entails either modifying the compiler to
;;; record the relationships (e.g., Symbolics Who-Calls Database) or doing
;;; a walk of loaded code and macroexpanding as needed (PCL code walker).
;;; The former is not portable, while the latter requires that the code
;;; used by macros be loaded and in working order. On the other hand, then
;;; we would need no special knowledge about macros (excluding the 24 special
;;; forms of Lisp).
;;;
;;; Parameters may be set to enable macro expansion in XREF. Then XREF
;;; will expand any macros for which it does not have predefined patterns.
;;; (For example, most Lisps will implement dolist as a macro. Since XREF
;;; has a pattern defined for dolist, it will not call macroexpand-1 on
;;; a form whose car is dolist.) For this to work properly, the code must
;;; be loaded before being processed by XREF, and XREF's parameters should
;;; be set so that it processes forms in their proper packages. 
;;;
;;; If macro expansion is disabled, the default rules for handling macro
;;; references may not be sufficient for some user-defined macros, because
;;; macros allow a variety of non-standard syntactic extensions to the
;;; language. In this case, the user may specify additional templates in
;;; a manner similar to that in which the core Lisp grammar was specified.
;;;


;;; ********************************
;;; User Guide *********************
;;; ********************************
;;; -----
;;; The following functions are called to cross reference the source files.
;;;
;;; XREF-FILES (&rest files)                                      [FUNCTION]
;;;    Grovels over the lisp code located in source file FILES, using
;;;    xref-file.
;;;
;;; XREF-FILE (filename &optional clear-tables verbose)       [Function]
;;;    Cross references the function and variable calls in FILENAME by
;;;    walking over the source code located in the file. Defaults type of
;;;    filename to ".lisp". Chomps on the code using record-callers and
;;;    record-callers*. If CLEAR-TABLES is T (the default), it clears the
;;;    callers database before processing the file. Specify CLEAR-TABLES as
;;;    nil to append to the database. If VERBOSE is T (the default), prints
;;;    out the name of the file, one progress dot for each form processed,
;;;    and the total number of forms.
;;;
;;; -----
;;; The following functions display information about the uses of the 
;;; specified symbol as a function, variable, or constant.
;;;
;;; LIST-CALLERS (symbol)                                         [FUNCTION]
;;;    Lists all functions which call SYMBOL as a function (function
;;;    invocation).
;;;
;;; LIST-READERS (symbol)                                         [FUNCTION]
;;;    Lists all functions which refer to SYMBOL as a variable
;;;    (variable reference).
;;;
;;; LIST-SETTERS (symbol)                                         [FUNCTION]
;;;    Lists all functions which bind/set SYMBOL as a variable
;;;    (variable mutation).
;;;
;;; LIST-USERS (symbol)                                           [FUNCTION]
;;;    Lists all functions which use SYMBOL as a variable or function.
;;;
;;; WHO-CALLS (symbol &optional how)                              [FUNCTION]
;;;    Lists callers of symbol. HOW may be :function, :reader, :setter,
;;;    or :variable."
;;;
;;; WHAT-FILES-CALL (symbol)                                      [FUNCTION]
;;;    Lists names of files that contain uses of SYMBOL
;;;    as a function, variable, or constant.
;;;
;;; SOURCE-FILE (symbol)                                          [FUNCTION]
;;;    Lists the names of files in which SYMBOL is defined/used.
;;;
;;; LIST-CALLEES (symbol)                                         [FUNCTION]
;;;    Lists names of functions and variables called by SYMBOL.
;;;
;;; -----
;;; The following functions may be useful for viewing the database and
;;; debugging the calling patterns.
;;;
;;; *LAST-FORM* ()                                                [VARIABLE]
;;;    The last form read from the file. Useful for figuring out what went
;;;    wrong when xref-file drops into the debugger.
;;;
;;; *XREF-VERBOSE* t                                              [VARIABLE]
;;;    When T, xref-file(s) prints out the names of the files it looks at,
;;;    progress dots, and the number of forms read.
;;;
;;; *TYPES-TO-IGNORE* (quote (:lisp :lisp2))                      [VARIABLE]
;;;    Default set of caller types (as specified in the patterns) to ignore
;;;    in the database handling functions. :lisp is CLtL 1st edition,
;;;    :lisp2 is additional patterns from CLtL 2nd edition.
;;;
;;; *HANDLE-PACKAGE-FORMS* ()                                     [VARIABLE]
;;;    When non-NIL, and XREF-FILE sees a package-setting form like
;;;    IN-PACKAGE, sets the current package to the specified package by
;;;    evaluating the form. When done with the file, xref-file resets the
;;;    package to its original value. In some of the displaying functions,
;;;    when this variable is non-NIL one may specify that all symbols from a
;;;    particular set of packages be ignored. This is only useful if the
;;;    files use different packages with conflicting names.
;;;
;;; *HANDLE-FUNCTION-FORMS* t                                     [VARIABLE]
;;;    When T, XREF-FILE tries to be smart about forms which occur in
;;;    a function position, such as lambdas and arbitrary Lisp forms.
;;;    If so, it recursively calls record-callers with pattern 'FORM.
;;;    If the form is a lambda, makes the caller a caller of
;;;    :unnamed-lambda.
;;;
;;; *HANDLE-MACRO-FORMS* t                                        [VARIABLE]
;;;    When T, if the file was loaded before being processed by XREF, and
;;;    the car of a form is a macro, it notes that the parent calls the
;;;    macro, and then calls macroexpand-1 on the form.
;;;
;;; *DEFAULT-GRAPHING-MODE* :call-graph                           [VARIABLE]
;;;    Specifies whether we graph up or down. If :call-graph, the children
;;;    of a node are the functions it calls. If :caller-graph, the
;;;    children of a node are the functions that call it.
;;;
;;; *INDENT-AMOUNT* 3                                             [VARIABLE]
;;;    Number of spaces to indent successive levels in PRINT-INDENTED-TREE.
;;;
;;; DISPLAY-DATABASE (&optional database types-to-ignore)         [FUNCTION]
;;;    Prints out the name of each symbol and all its callers. Specify
;;;    database :callers (the default) to get function call references,
;;;    :file to the get files in which the symbol is called, :readers to get
;;;    variable references, and :setters to get variable binding and
;;;    assignments. Ignores functions of types listed in types-to-ignore.
;;;
;;; PRINT-CALLER-TREES (&key (mode *default-graphing-mode*)       [FUNCTION]
;;;                     (types-to-ignore *types-to-ignore*)
;;;                     compact root-nodes)
;;;    Prints the calling trees (which may actually be a full graph and not
;;;    necessarily a DAG) as indented text trees using
;;;    PRINT-INDENTED-TREE. MODE is :call-graph for trees where the children
;;;    of a node are the functions called by the node, or :caller-graph for
;;;    trees where the children of a node are the functions the node calls.
;;;    TYPES-TO-IGNORE is a list of funcall types (as specified in the
;;;    patterns) to ignore in printing out the database. For example,
;;;    '(:lisp) would ignore all calls to common lisp functions. COMPACT is
;;;    a flag to tell the program to try to compact the trees a bit by not
;;;    printing trees if they have already been seen. ROOT-NODES is a list
;;;    of root nodes of trees to display. If ROOT-NODES is nil, tries to
;;;    find all root nodes in the database.
;;;
;;; MAKE-CALLER-TREE (&optional (mode *default-graphing-mode*)    [FUNCTION]
;;;                   (types-to-ignore *types-to-ignore*)
;;;                   compact)
;;;    Outputs list structure of a tree which roughly represents the
;;;    possibly cyclical structure of the caller database.
;;;    If mode is :call-graph, the children of a node are the functions
;;;    it calls. If mode is :caller-graph, the children of a node are the
;;;    functions that call it.
;;;    If compact is T, tries to eliminate the already-seen nodes, so
;;;    that the graph for a node is printed at most once. Otherwise it will
;;;    duplicate the node's tree (except for cycles). This is usefull
;;;    because the call tree is actually a directed graph, so we can either
;;;    duplicate references or display only the first one.
;;;
;;; DETERMINE-FILE-DEPENDENCIES (&optional database)          [FUNCTION]
;;;    Makes a hash table of file dependencies for the references listed in
;;;    DATABASE. This function may be useful for automatically resolving
;;;    file references for automatic creation of a system definition
;;;    (defsystem).
;;;
;;; PRINT-FILE-DEPENDENCIES (&optional database)              [FUNCTION]
;;;    Prints a list of file dependencies for the references listed in
;;;    DATABASE. This function may be useful for automatically computing
;;;    file loading constraints for a system definition tool.
;;;
;;; WRITE-CALLERS-DATABASE-TO-FILE (filename)                     [FUNCTION]
;;;    Saves the contents of the current callers database to a file. This
;;;    file can be loaded to restore the previous contents of the
;;;    database. (For large systems it can take a long time to crunch
;;;    through the code, so this can save some time.)
;;;
;;; -----
;;; The following macros define new function and macro call patterns.
;;; They may be used to extend the static analysis tool to handle
;;; new def forms, extensions to Common Lisp, and program defs.
;;;
;;; DEFINE-PATTERN-SUBSTITUTION (name pattern)                    [MACRO]
;;;    Defines NAME to be equivalent to the specified pattern. Useful for
;;;    making patterns more readable. For example, the LAMBDA-LIST is
;;;    defined as a pattern substitution, making the definition of the
;;;    DEFUN caller-pattern simpler.
;;;
;;; DEFINE-CALLER-PATTERN (name pattern &optional caller-type)    [MACRO]
;;;    Defines NAME as a function/macro call with argument structure
;;;    described by PATTERN. CALLER-TYPE, if specified, assigns a type to
;;;    the pattern, which may be used to exclude references to NAME while
;;;    viewing the database. For example, all the Common Lisp definitions
;;;    have a caller-type of :lisp or :lisp2, so that you can exclude
;;;    references to common lisp functions from the calling tree.
;;;
;;; DEFINE-VARIABLE-PATTERN (name &optional caller-type)          [MACRO]
;;;    Defines NAME as a variable reference of type CALLER-TYPE. This is
;;;    mainly used to establish the caller-type of the variable.
;;;
;;; DEFINE-CALLER-PATTERN-SYNONYMS (source destinations)          [MACRO]
;;;    For defining function caller pattern syntax synonyms. For each name
;;;    in DESTINATIONS, defines its pattern as a copy of the definition
;;;    of SOURCE. Allows a large number of identical patterns to be defined
;;;    simultaneously. Must occur after the SOURCE has been defined.
;;;
;;; -----
;;; This system includes pattern definitions for the latest
;;; common lisp specification, as published in Guy Steele,
;;; Common Lisp: The Language, 2nd Edition.
;;;
;;; Patterns may be either structures to match, or a predicate
;;; like symbolp/numberp/stringp. The pattern specification language
;;; is similar to the notation used in CLtL2, but in a more lisp-like 
;;; form:
;;;    (:eq name)           The form element must be eq to the symbol NAME.
;;;    (:test test)         TEST must be true when applied to the form element.
;;;    (:typep type)        The form element must be of type TYPE.
;;;    (:or pat1 pat2 ...)  Tries each of the patterns in left-to-right order,
;;;                         until one succeeds.
;;;                         Equivalent to { pat1 | pat2 | ... }
;;;    (:rest pattern)      The remaining form elements are grouped into a
;;;                         list which is matched against PATTERN.
;;;    (:optional pat1 ...) The patterns may optionally match against the
;;;                         form element.
;;;                         Equivalent to [ pat1 ... ].
;;;    (:star pat1 ...)     The patterns may match against the patterns
;;;                         any number of times, including 0.
;;;                         Equivalent to { pat1 ... }*.
;;;    (:plus pat1 ...)     The patterns may match against the patterns
;;;                         any number of times, but at least once.
;;;                         Equivalent to { pat1 ... }+.
;;;    &optional, &key,     Similar in behavior to the corresponding
;;;    &rest                lambda-list keywords.
;;;    FORM                 A random lisp form. If a cons, assumes the
;;;                         car is a function or macro and tries to
;;;                         match the args against that symbol's pattern.
;;;                         If a symbol, assumes it's a variable reference.
;;;    :ignore              Ignores the corresponding form element.
;;;    NAME                 The corresponding form element should be
;;;                         the name of a new definition (e.g., the
;;;                         first arg in a defun pattern is NAME.
;;;    FUNCTION, MACRO      The corresponding form element should be
;;;                         a function reference not handled by FORM.
;;;                         Used in the definition of apply and funcall.
;;;    VAR                  The corresponding form element should be
;;;                         a variable definition or mutation. Used
;;;                         in the definition of let, let*, etc.
;;;    VARIABLE             The corresponding form element should be
;;;                         a variable reference. 
;;;
;;; In all other pattern symbols, it looks up the symbols pattern substitution
;;; and recursively matches against the pattern. Automatically destructures
;;; list structure that does not include consing dots.
;;;
;;; Among the pattern substitution names defined are:
;;;    STRING, SYMBOL, NUMBER    Appropriate :test patterns.
;;;    LAMBDA-LIST               Matches against a lambda list.
;;;    BODY                      Matches against a function body definition.
;;;    FN                        Matches against #'function, 'function,
;;;                              and lambdas. This is used in the definition
;;;                              of apply, funcall, and the mapping patterns.
;;;    and others...
;;;
;;; Here's some sample pattern definitions:
;;; (define-caller-pattern defun 
;;;   (name lambda-list
;;;	(:star (:or documentation-string declaration))
;;;	(:star form))
;;;  :lisp)
;;; (define-caller-pattern funcall (fn (:star form)) :lisp)
;;;
;;; In general, the system is intelligent enough to handle any sort of
;;; simple funcall. One only need specify the syntax for functions and
;;; macros which use optional arguments, keyword arguments, or some
;;; argument positions are special, such as in apply and funcall, or
;;; to indicate that the function is of the specified caller type.
;;;
;;;
;;; NOTES:
;;;
;;;    XRef assumes syntactically correct lisp code.
;;;
;;;    This is by no means perfect. For example, let and let* are treated
;;;    identically, instead of differentiating between serial and parallel
;;;    binding. But it's still a useful tool. It can be helpful in 
;;;    maintaining code, debugging problems with patch files, determining
;;;    whether functions are multiply defined, and help you remember where
;;;    a function is defined or called.
;;;
;;;    XREF runs best when compiled.

;;; ********************************
;;; References *********************
;;; ********************************
;;;
;;; Xerox Interlisp Masterscope Program:
;;;   Larry M Masinter, Global program analysis in an interactive environment
;;;   PhD Thesis, Stanford University, 1980. 
;;;
;;; Symbolics Who-Calls Database:
;;;   User's Guide to Symbolics Computers, Volume 1, Cambridge, MA, July 1986
;;;   Genera 7.0, pp 183-185.
;;;   

;;; ********************************
;;; Example ************************
;;; ********************************
;;; 
;;; Here is an example of running XREF on a short program.
;;; [In Scribe documentation, give a simple short program and resulting
;;;  XREF output, including postscript call graphs.]
#|
<cl> (xref:xref-file  "/afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp")
Cross-referencing file /afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp.
................................................
48 forms processed.
<cl> (xref:display-database :readers)

593 594 595 596
*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE.
Helmut Eller's avatar
Helmut Eller committed
597 598 599 600
*WITHIN-LEVEL-SPACING* is referenced by BREADTH CALCULATE-POSITION-INFO.
*DIRECTION* is referenced by CREATE-POSITION-INFO.
*LINK-OFFSET* is referenced by OFFSET-OF-LINK-FROM-ATTACHMENT-POINT.
*ROOT-IS-SEQUENCE* is referenced by GRAPH.
601 602 603 604
*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE.
*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
Helmut Eller's avatar
Helmut Eller committed
605 606
*DEFAULT-GRAPH-POSITION* is referenced by CREATE-POSITION-INFO.
*GRAPHING-CUTOFF-DEPTH* is referenced by CREATE-NODE-STRUCTURE.
607 608
*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION
CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE.
Helmut Eller's avatar
Helmut Eller committed
609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661
*GRAPH-TYPE* is referenced by CREATE-NODE-STRUCTURE.
<cl> (xref:print-caller-trees :root-nodes '(display-graph))

Rooted calling trees:
  DISPLAY-GRAPH
     CREATE-POSITION-INFO
        CALCULATE-POSITION-INFO
           CALCULATE-POSITION
              NODE-POSITION-ALREADY-SET-FLAG
              NODE-LEVEL-ALREADY-SET-FLAG
              CALCULATE-POSITION-IN-LEVEL
                 NODE-CHILDREN
                 NODE-LEVEL
                 CALCULATE-POSITION
                 NEW-CALCULATE-BREADTH
                    NODE-CHILDREN
                    BREADTH
                       OPPOSITE-DIMENSION
                          NODE-HEIGHT
                          NODE-WIDTH
                    NEW-CALCULATE-BREADTH
                    NODE-PARENTS
                 OPPOSITE-DIMENSION
                    NODE-HEIGHT
                    NODE-WIDTH
                 OPPOSITE-POSITION
                    NODE-Y
                    NODE-X
        NODE-LEVEL
        CALCULATE-LEVEL-POSITION
           NODE-LEVEL
           NODE-POSITION
              NODE-X
              NODE-Y
           DIMENSION
              NODE-WIDTH
              NODE-HEIGHT
        CALCULATE-LEVEL-POSITION-BEFORE
           NODE-LEVEL
           NODE-POSITION
              NODE-X
              NODE-Y
           NODE-WIDTH
           NODE-HEIGHT
           DIMENSION
              NODE-WIDTH
              NODE-HEIGHT
|#

;;; ****************************************************************
;;; List Callers ***************************************************
;;; ****************************************************************

662
(defpackage :pxref
Helmut Eller's avatar
Helmut Eller committed
663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698
  (:use :common-lisp)
  (:export #:list-callers 
	   #:list-users 
	   #:list-readers 
	   #:list-setters
	   #:what-files-call
	   #:who-calls 
	   #:list-callees 
	   #:source-file 
	   #:clear-tables
	   #:define-pattern-substitution 
	   #:define-caller-pattern 
	   #:define-variable-pattern 
	   #:define-caller-pattern-synonyms
	   #:clear-patterns
	   #:*last-form* 
	   #:*xref-verbose* 
	   #:*handle-package-forms* 
	   #:*handle-function-forms*
	   #:*handle-macro-forms*
	   #:*types-to-ignore*
	   #:*last-caller-tree* 
	   #:*default-graphing-mode* 
	   #:*indent-amount*
	   #:xref-file 
	   #:xref-files
	   #:write-callers-database-to-file
	   #:display-database
	   #:print-caller-trees 
	   #:make-caller-tree 
	   #:print-indented-tree 
	   #:determine-file-dependencies 
	   #:print-file-dependencies
	   #:psgraph-xref
	   ))

699
(in-package "PXREF")
Helmut Eller's avatar
Helmut Eller committed
700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237

;;; Warn user if they're loading the source instead of compiling it first.
;(eval-when (compile load eval)
;  (defvar compiled-p nil))
;(eval-when (compile load)
;  (setq compiled-p t))
;(eval-when (load eval)
;  (unless compiled-p
;    (warn "This file should be compiled before loading for best results.")))
(eval-when (eval)
   (warn "This file should be compiled before loading for best results."))


;;; ********************************
;;; Primitives *********************
;;; ********************************
(defun lookup (symbol environment)
  (dolist (frame environment)
    (when (member symbol frame)
      (return symbol))))

(defun car-eq (list item)
  (and (consp list)
       (eq (car list) item)))

;;; ********************************
;;; Callers Database ***************
;;; ********************************
(defvar *file-callers-database* (make-hash-table :test #'equal)
  "Contains name and list of file callers (files which call) for that name.")
(defvar *callers-database* (make-hash-table :test #'equal)
  "Contains name and list of callers (function invocation) for that name.")
(defvar *readers-database* (make-hash-table :test #'equal)
  "Contains name and list of readers (variable use) for that name.")
(defvar *setters-database* (make-hash-table :test #'equal)
  "Contains name and list of setters (variable mutation) for that name.")
(defvar *callees-database* (make-hash-table :test #'equal)
  "Contains name and list of functions and variables it calls.")
(defun callers-list (name &optional (database :callers))
  (case database
    (:file    (gethash name *file-callers-database*))
    (:callees (gethash name *callees-database*))
    (:callers (gethash name *callers-database*))
    (:readers (gethash name *readers-database*))
    (:setters (gethash name *setters-database*))))
(defsetf callers-list (name &optional (database :callers)) (caller)
  `(setf (gethash ,name (case ,database
			  (:file    *file-callers-database*)
			  (:callees *callees-database*)
			  (:callers *callers-database*)
			  (:readers *readers-database*)
			  (:setters *setters-database*)))
	 ,caller))

(defun list-callers (symbol)
  "Lists all functions which call SYMBOL as a function (function invocation)."
  (callers-list symbol :callers))
(defun list-readers (symbol)
  "Lists all functions which refer to SYMBOL as a variable 
   (variable reference)."
  (callers-list symbol :readers))
(defun list-setters (symbol)
  "Lists all functions which bind/set SYMBOL as a variable 
   (variable mutation)."
  (callers-list symbol :setters))
(defun list-users (symbol)
  "Lists all functions which use SYMBOL as a variable or function."
  (values (list-callers symbol)
	  (list-readers symbol)
	  (list-setters symbol)))
(defun who-calls (symbol &optional how)
  "Lists callers of symbol. HOW may be :function, :reader, :setter,
   or :variable."
  ;; would be nice to have :macro and distinguish variable
  ;; binding from assignment. (i.e., variable binding, assignment, and use)
  (case how
    (:function (list-callers symbol))
    (:reader   (list-readers symbol))
    (:setter   (list-setters symbol))
    (:variable (append (list-readers symbol) 
		       (list-setters symbol)))
    (otherwise (append (list-callers symbol)
		       (list-readers symbol)
		       (list-setters symbol)))))
(defun what-files-call (symbol)
  "Lists names of files that contain uses of SYMBOL 
   as a function, variable, or constant."
  (callers-list symbol :file))
(defun list-callees (symbol)
  "Lists names of functions and variables called by SYMBOL."
  (callers-list symbol :callees))

(defvar *source-file* (make-hash-table :test #'equal)
  "Contains function name and source file for that name.")
(defun source-file (symbol)
  "Lists the names of files in which SYMBOL is defined/used."
  (gethash symbol *source-file*))
(defsetf source-file (name) (value)
  `(setf (gethash ,name *source-file*) ,value))

(defun clear-tables ()
  (clrhash *file-callers-database*)
  (clrhash *callers-database*)
  (clrhash *callees-database*)
  (clrhash *readers-database*)
  (clrhash *setters-database*)
  (clrhash *source-file*))


;;; ********************************
;;; Pattern Database ***************
;;; ********************************
;;; Pattern Types
(defvar *pattern-caller-type* (make-hash-table :test #'equal))
(defun pattern-caller-type (name)
  (gethash name *pattern-caller-type*))
(defsetf pattern-caller-type (name) (value)
  `(setf (gethash ,name *pattern-caller-type*) ,value))

;;; Pattern Substitutions
(defvar *pattern-substitution-table* (make-hash-table :test #'equal)
  "Stores general patterns for function destructuring.")
(defun lookup-pattern-substitution (name)
  (gethash name *pattern-substitution-table*))
(defmacro define-pattern-substitution (name pattern)
  "Defines NAME to be equivalent to the specified pattern. Useful for
   making patterns more readable. For example, the LAMBDA-LIST is 
   defined as a pattern substitution, making the definition of the
   DEFUN caller-pattern simpler."
  `(setf (gethash ',name *pattern-substitution-table*)
	 ',pattern))

;;; Function/Macro caller patterns: 
;;; The car of the form is skipped, so we don't need to specify
;;; (:eq function-name) like we would for a substitution.
;;;
;;; Patterns must be defined in the XREF package because the pattern
;;; language is tested by comparing symbols (using #'equal) and not
;;; their printreps. This is fine for the lisp grammer, because the XREF
;;; package depends on the LISP package, so a symbol like 'xref::cons is
;;; translated automatically into 'lisp::cons. However, since
;;; (equal 'foo::bar 'baz::bar) returns nil unless both 'foo::bar and
;;; 'baz::bar are inherited from the same package (e.g., LISP), 
;;; if package handling is turned on the user must specify package 
;;; names in the caller pattern definitions for functions that occur
;;; in packages other than LISP, otherwise the symbols will not match.
;;; 
;;; Perhaps we should enforce the definition of caller patterns in the
;;; XREF package by wrapping the body of define-caller-pattern in
;;; the XREF package:
;;;    (defmacro define-caller-pattern (name value &optional caller-type)
;;;      (let ((old-package *package*))
;;;        (setf *package* (find-package "XREF"))
;;;        (prog1
;;;    	     `(progn
;;;    	        (when ',caller-type
;;;         	     (setf (pattern-caller-type ',name) ',caller-type))
;;;    	        (when ',value 
;;;    	          (setf (gethash ',name *caller-pattern-table*)
;;;    		        ',value)))
;;;          (setf *package* old-package)))) 
;;; Either that, or for the purpose of pattern testing we should compare
;;; printreps. [The latter makes the primitive patterns like VAR
;;; reserved words.]
(defvar *caller-pattern-table* (make-hash-table :test #'equal)
  "Stores patterns for function destructuring.")
(defun lookup-caller-pattern (name)
  (gethash name *caller-pattern-table*))
(defmacro define-caller-pattern (name pattern &optional caller-type)
  "Defines NAME as a function/macro call with argument structure
   described by PATTERN. CALLER-TYPE, if specified, assigns a type to
   the pattern, which may be used to exclude references to NAME while
   viewing the database. For example, all the Common Lisp definitions
   have a caller-type of :lisp or :lisp2, so that you can exclude 
   references to common lisp functions from the calling tree."
  `(progn
     (when ',caller-type
       (setf (pattern-caller-type ',name) ',caller-type))
     (when ',pattern 
       (setf (gethash ',name *caller-pattern-table*)
	     ',pattern))))

;;; For defining variables
(defmacro define-variable-pattern (name &optional caller-type)
  "Defines NAME as a variable reference of type CALLER-TYPE. This is
   mainly used to establish the caller-type of the variable."
  `(progn
     (when ',caller-type
       (setf (pattern-caller-type ',name) ',caller-type))))

;;; For defining synonyms. Means much less space taken up by the patterns.
(defmacro define-caller-pattern-synonyms (source destinations)
  "For defining function caller pattern syntax synonyms. For each name
   in DESTINATIONS, defines its pattern as a copy of the definition of SOURCE.
   Allows a large number of identical patterns to be defined simultaneously.
   Must occur after the SOURCE has been defined."
  `(let ((source-type (pattern-caller-type ',source))
	 (source-pattern (gethash ',source *caller-pattern-table*)))
     (when source-type
       (dolist (dest ',destinations)
	 (setf (pattern-caller-type dest) source-type)))
     (when source-pattern
       (dolist (dest ',destinations)
	 (setf (gethash dest *caller-pattern-table*)
	       source-pattern)))))

(defun clear-patterns ()
  (clrhash *pattern-substitution-table*)
  (clrhash *caller-pattern-table*)
  (clrhash *pattern-caller-type*))

;;; ********************************
;;; Cross Reference Files **********
;;; ********************************
(defvar *last-form* ()
  "The last form read from the file. Useful for figuring out what went wrong
   when xref-file drops into the debugger.")

(defvar *xref-verbose* t
  "When T, xref-file(s) prints out the names of the files it looks at,
   progress dots, and the number of forms read.")

;;; This needs to first clear the tables?
(defun xref-files (&rest files)
  "Grovels over the lisp code located in source file FILES, using xref-file."
  ;; If the arg is a list, use it.
  (when (listp (car files)) (setq files (car files)))
  (dolist (file files)
    (xref-file file nil))
  (values))

(defvar *handle-package-forms* nil	;'(lisp::in-package)
  "When non-NIL, and XREF-FILE sees a package-setting form like IN-PACKAGE,
   sets the current package to the specified package by evaluating the
   form. When done with the file, xref-file resets the package to its 
   original value. In some of the displaying functions, when this variable
   is non-NIL one may specify that all symbols from a particular set of
   packages be ignored. This is only useful if the files use different
   packages with conflicting names.")

(defvar *normal-readtable* (copy-readtable nil)
  "Normal, unadulterated CL readtable.")

(defun xref-file (filename &optional (clear-tables t) (verbose *xref-verbose*))
  "Cross references the function and variable calls in FILENAME by
   walking over the source code located in the file. Defaults type of
   filename to \".lisp\". Chomps on the code using record-callers and
   record-callers*. If CLEAR-TABLES is T (the default), it clears the callers
   database before processing the file. Specify CLEAR-TABLES as nil to
   append to the database. If VERBOSE is T (the default), prints out the
   name of the file, one progress dot for each form processed, and the
   total number of forms."
  ;; Default type to "lisp"
  (when (and (null (pathname-type filename))
	     (not  (probe-file filename)))
    (cond ((stringp filename)
	   (setf filename (concatenate 'string filename ".lisp")))
	  ((pathnamep filename)
	   (setf filename (merge-pathnames filename
					   (make-pathname :type "lisp"))))))
  (when clear-tables (clear-tables))
  (let ((count 0)
	(old-package *package*)
	(*readtable* *normal-readtable*))
    (when verbose
      (format t "~&Cross-referencing file ~A.~&" filename))
    (with-open-file (stream filename :direction :input)
      (do ((form (read stream nil :eof) (read stream nil :eof)))
	  ((eq form :eof))
	(incf count)
	(when verbose
	  (format *standard-output* ".")
	  (force-output *standard-output*))
	(setq *last-form* form)
	(record-callers filename form)
	;; Package Magic.
	(when (and *handle-package-forms*
		   (consp form)
		   (member (car form) *handle-package-forms*))
	  (eval form))))
    (when verbose 
      (format t "~&~D forms processed." count))
    (setq *package* old-package)
    (values)))

(defvar *handle-function-forms* t
  "When T, XREF-FILE tries to be smart about forms which occur in
   a function position, such as lambdas and arbitrary Lisp forms.
   If so, it recursively calls record-callers with pattern 'FORM.
   If the form is a lambda, makes the caller a caller of :unnamed-lambda.") 

(defvar *handle-macro-forms* t
  "When T, if the file was loaded before being processed by XREF, and the
   car of a form is a macro, it notes that the parent calls the macro,
   and then calls macroexpand-1 on the form.") 

(defvar *callees-database-includes-variables* nil)

(defun record-callers (filename form 
				&optional pattern parent (environment nil)
				funcall)
  "RECORD-CALLERS is the main routine used to walk down the code. It matches
   the PATTERN against the FORM, possibly adding statements to the database.
   PARENT is the name defined by the current outermost definition; it is
   the caller of the forms in the body (e.g., FORM). ENVIRONMENT is used
   to keep track of the scoping of variables. FUNCALL deals with the type
   of variable assignment and hence how the environment should be modified.
   RECORD-CALLERS handles atomic patterns and simple list-structure patterns.
   For complex list-structure pattern destructuring, it calls RECORD-CALLERS*."
;  (when form)
  (unless pattern (setq pattern 'FORM))
  (cond ((symbolp pattern)
	 (case pattern
	   (:IGNORE
	    ;; Ignores the rest of the form.
	    (values t parent environment))
	   (NAME    
	    ;; This is the name of a new definition.
	    (push filename (source-file form))
	    (values t form   environment))
	   ((FUNCTION MACRO)
	    ;; This is the name of a call.
	    (cond ((and *handle-function-forms* (consp form))
		   ;; If we're a cons and special handling is on,
		   (when (eq (car form) 'lambda)
		     (pushnew filename (callers-list :unnamed-lambda :file))
		     (when parent
		       (pushnew parent (callers-list :unnamed-lambda
						     :callers))
		       (pushnew :unnamed-lambda (callers-list parent
							      :callees))))
		   (record-callers filename form 'form parent environment))
		  (t 
		   ;; If we're just a regular function name call.
		   (pushnew filename (callers-list form :file))
		   (when parent
		     (pushnew parent (callers-list form :callers))
		     (pushnew form (callers-list parent :callees)))
		   (values t parent environment)))) 
	   (VAR     
	    ;; This is the name of a new variable definition.
	    ;; Includes arglist parameters.
	    (when (and (symbolp form) (not (keywordp form))
		       (not (member form lambda-list-keywords)))
	      (pushnew form (car environment))
	      (pushnew filename (callers-list form :file))
	      (when parent 
;		  (pushnew form (callers-list parent :callees))
		(pushnew parent (callers-list form :setters)))
	      (values t parent environment)))
	   (VARIABLE
	    ;; VAR reference
	    (pushnew filename (callers-list form :file))
	    (when (and parent (not (lookup form environment)))
	      (pushnew parent (callers-list form :readers))
	      (when *callees-database-includes-variables*
		(pushnew form (callers-list parent :callees))))
	    (values t parent environment))
	   (FORM    
	    ;; A random form (var or funcall).
	    (cond ((consp form)
		   ;; Get new pattern from TAG.
		   (let ((new-pattern (lookup-caller-pattern (car form))))
		     (pushnew filename (callers-list (car form) :file))
		     (when parent
		       (pushnew parent (callers-list (car form) :callers))
		       (pushnew (car form) (callers-list parent :callees)))
		     (cond ((and new-pattern (cdr form))
			    ;; Special Pattern and there's stuff left
			    ;; to be processed. Note that we check if
			    ;; a pattern is defined for the form before
			    ;; we check to see if we can macroexpand it.
			    (record-callers filename (cdr form) new-pattern
					    parent environment :funcall))
			   ((and *handle-macro-forms*
				 (symbolp (car form)) ; pnorvig 9/9/93
				 (macro-function (car form)))
			    ;; The car of the form is a macro and
			    ;; macro processing is turned on. Macroexpand-1
			    ;; the form and try again.
			    (record-callers filename 
					    (macroexpand-1 form)
					    'form parent environment 
					    :funcall))
			   ((null (cdr form))
			    ;; No more left to be processed. Note that
			    ;; this must occur after the macros clause,
			    ;; since macros can expand into more code.
			    (values t parent environment))
			   (t
			    ;; Random Form. We assume it is a function call.
			    (record-callers filename (cdr form)
					    '((:star FORM))
					    parent environment :funcall)))))
		  (t 
		   (when (and (not (lookup form environment))
			      (not (numberp form))
			      ;; the following line should probably be 
			      ;; commented out?
			      (not (keywordp form))
			      (not (stringp form))
			      (not (eq form t))
			      (not (eq form nil)))
		     (pushnew filename (callers-list form :file))
		     ;; ??? :callers
		     (when parent
		       (pushnew parent (callers-list form :readers))
		       (when *callees-database-includes-variables*
			 (pushnew form (callers-list parent :callees)))))
		   (values t parent environment))))
	   (otherwise 
	    ;; Pattern Substitution
	    (let ((new-pattern (lookup-pattern-substitution pattern)))
	      (if new-pattern
		  (record-callers filename form new-pattern 
				  parent environment)
		  (when (eq pattern form)
		    (values t parent environment)))))))
	((consp pattern)
	 (case (car pattern)
	   (:eq    (when (eq (second pattern) form)
		     (values t parent environment)))
	   (:test  (when (funcall (eval (second pattern)) form)
		     (values t parent environment)))
	   (:typep (when (typep form (second pattern))
		     (values t parent environment)))
	   (:or    (dolist (subpat (rest pattern))
		     (multiple-value-bind (processed parent environment)
			 (record-callers filename form subpat
					 parent environment)
		       (when processed
			 (return (values processed parent environment))))))
	   (:rest			; (:star :plus :optional :rest)
	    (record-callers filename form (second pattern)
			    parent environment))
	   (otherwise
	    (multiple-value-bind (d p env)
		(record-callers* filename form pattern 
				 parent (cons nil environment))
	      (values d p (if funcall environment env))))))))

(defun record-callers* (filename form pattern parent environment
				 &optional continuation 
				 in-optionals in-keywords)
  "RECORD-CALLERS* handles complex list-structure patterns, such as
   ordered lists of subpatterns, patterns involving :star, :plus,
   &optional, &key, &rest, and so on. CONTINUATION is a stack of
   unprocessed patterns, IN-OPTIONALS and IN-KEYWORDS are corresponding
   stacks which determine whether &rest or &key has been seen yet in
   the current pattern."   
  ;; form must be a cons or nil.
;  (when form)
  (if (null pattern)
      (if (null continuation)
	  (values t parent environment)
	  (record-callers* filename form (car continuation) parent environment
			   (cdr continuation) 
			   (cdr in-optionals)
			   (cdr in-keywords)))
      (let ((pattern-elt (car pattern)))
	(cond ((car-eq pattern-elt :optional)
	       (if (null form) 
		   (values t parent environment)
		   (multiple-value-bind (processed par env)
		       (record-callers* filename form (cdr pattern-elt)
					parent environment
					(cons (cdr pattern) continuation)
					(cons (car in-optionals) in-optionals)
					(cons (car in-keywords) in-keywords))
		     (if processed
			 (values processed par env)
			 (record-callers* filename form (cdr pattern)
					  parent environment continuation
					  in-optionals in-keywords)))))
	      ((car-eq pattern-elt :star)
	       (if (null form)
		   (values t parent environment)
		   (multiple-value-bind (processed par env)
		       (record-callers* filename form (cdr pattern-elt)
					parent environment
					(cons pattern continuation)
					(cons (car in-optionals) in-optionals)
					(cons (car in-keywords) in-keywords))
		     (if processed
			 (values processed par env)
			 (record-callers* filename form (cdr pattern)
					  parent environment continuation
					  in-optionals in-keywords)))))
	      ((car-eq pattern-elt :plus)
	       (record-callers* filename form (cdr pattern-elt)
				parent environment
				(cons (cons (cons :star (cdr pattern-elt))
					    (cdr pattern))
				      continuation)
				(cons (car in-optionals) in-optionals)
				(cons (car in-keywords) in-keywords)))
	      ((car-eq pattern-elt :rest)
	       (record-callers filename form pattern-elt parent environment))
	      ((eq pattern-elt '&optional)
	       (record-callers* filename form (cdr pattern)
				parent environment continuation
				(cons t in-optionals)
				(cons (car in-keywords) in-keywords)))
	      ((eq pattern-elt '&rest)
	       (record-callers filename form (second pattern)
			       parent environment))
	      ((eq pattern-elt '&key)
	       (record-callers* filename form (cdr pattern)
				parent environment continuation
				(cons (car in-optionals) in-optionals)
				(cons t in-keywords)))
	      ((null form)
	       (when (or (car in-keywords) (car in-optionals))
		 (values t parent environment)))
	      ((consp form)
	       (multiple-value-bind (processed parent environment)
		   (record-callers filename (if (car in-keywords)
						(cadr form)
						(car form))
				   pattern-elt
				   parent environment)
		 (cond (processed
			(record-callers* filename (if (car in-keywords)
						      (cddr form)
						      (cdr form))
					 (cdr pattern)
					 parent environment
					 continuation
					 in-optionals in-keywords))
		       ((or (car in-keywords)
			    (car in-optionals))
			(values t parent environment)))))))))


;;; ********************************
;;; Misc Utilities *****************
;;; ********************************
(defvar *types-to-ignore*
1238 1239
  '(:lisp			; CLtL 1st Edition
    :lisp2			; CLtL 2nd Edition additional patterns
Helmut Eller's avatar
Helmut Eller committed
1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914
    )
  "Default set of caller types (as specified in the patterns) to ignore
   in the database handling functions. :lisp is CLtL 1st edition,
   :lisp2 is additional patterns from CLtL 2nd edition.")

(defun display-database (&optional (database :callers) 
				   (types-to-ignore *types-to-ignore*))
  "Prints out the name of each symbol and all its callers. Specify database
   :callers (the default) to get function call references, :fill to the get
   files in which the symbol is called, :readers to get variable references,
   and :setters to get variable binding and assignments. Ignores functions
   of types listed in types-to-ignore."
  (maphash #'(lambda (name callers)
	       (unless (or (member (pattern-caller-type name)
				   types-to-ignore)
			   ;; When we're doing fancy package crap,
			   ;; allow us to ignore symbols based on their
			   ;; packages.
			   (when *handle-package-forms*
			     (member (symbol-package name)
				     types-to-ignore
				     :key #'find-package)))
		 (format t "~&~S is referenced by~{ ~S~}."
			 name callers)))
	   (ecase database
	     (:file    *file-callers-database*)
	     (:callers *callers-database*)
	     (:readers *readers-database*)
	     (:setters *setters-database*))))

(defun write-callers-database-to-file (filename)
  "Saves the contents of the current callers database to a file. This
   file can be loaded to restore the previous contents of the
   database. (For large systems it can take a long time to crunch
   through the code, so this can save some time.)"
  (with-open-file (stream filename :direction :output)
    (format stream "~&(clear-tables)")
    (maphash #'(lambda (x y) 
		 (format stream "~&(setf (source-file '~S) '~S)"
			 x y))
	     *source-file*)
    (maphash #'(lambda (x y) 
		 (format stream "~&(setf (callers-list '~S :file) '~S)"
			 x y))
	     *file-callers-database*)
    (maphash #'(lambda (x y) 
		 (format stream "~&(setf (callers-list '~S :callers) '~S)"
			 x y))
	     *callers-database*)
    (maphash #'(lambda (x y) 
		 (format stream "~&(setf (callers-list '~S :callees) '~S)"
			 x y))
	     *callees-database*)
    (maphash #'(lambda (x y) 
		 (format stream "~&(setf (callers-list '~S :readers) '~S)"
			 x y))
	     *readers-database*)
    (maphash #'(lambda (x y) 
		 (format stream "~&(setf (callers-list '~S :setters) '~S)"
			 x y))
	     *setters-database*)))


;;; ********************************
;;; Print Caller Trees *************
;;; ********************************
;;; The following function is useful for reversing a caller table into
;;; a callee table. Possibly later we'll extend xref to create two 
;;; such database hash tables. Needs to include vars as well.
(defun invert-hash-table (table &optional (types-to-ignore *types-to-ignore*))
  "Makes a copy of the hash table in which (name value*) pairs
   are inverted to (value name*) pairs."
  (let ((target (make-hash-table :test #'equal)))
    (maphash #'(lambda (key values)
		 (dolist (value values)
		   (unless (member (pattern-caller-type key) 
				   types-to-ignore)
		     (pushnew key (gethash value target)))))
	     table)
    target))

;;; Resolve file references for automatic creation of a defsystem file.
(defun determine-file-dependencies (&optional (database *callers-database*))
  "Makes a hash table of file dependencies for the references listed in
   DATABASE. This function may be useful for automatically resolving
   file references for automatic creation of a system definition (defsystem)."
  (let ((file-ref-ht  (make-hash-table :test #'equal)))
    (maphash #'(lambda (key values)
		 (let ((key-file (source-file key)))
		   (when key
		     (dolist (value values)
		       (let ((value-file (source-file value)))
			 (when value-file
			   (dolist (s key-file)
			     (dolist (d value-file)
			       (pushnew d (gethash s file-ref-ht))))))))))
	     database)
    file-ref-ht))

(defun print-file-dependencies (&optional (database *callers-database*))
  "Prints a list of file dependencies for the references listed in DATABASE.
   This function may be useful for automatically computing file loading
   constraints for a system definition tool."
  (maphash #'(lambda (key value) (format t "~&~S --> ~S" key value))
	   (determine-file-dependencies database)))

;;; The following functions demonstrate a possible way to interface
;;; xref to a graphical browser such as psgraph to mimic the capabilities
;;; of Masterscope's graphical browser. 

(defvar *last-caller-tree* nil)

(defvar *default-graphing-mode* :call-graph
  "Specifies whether we graph up or down. If :call-graph, the children
   of a node are the functions it calls. If :caller-graph, the children
   of a node are the functions that call it.") 

(defun gather-tree (parents &optional already-seen 
			    (mode *default-graphing-mode*)
			    (types-to-ignore *types-to-ignore*) compact)
  "Extends the tree, copying it into list structure, until it repeats
   a reference (hits a cycle)."
  (let ((*already-seen* nil)
	(database (case mode
		    (:call-graph   *callees-database*)
		    (:caller-graph *callers-database*))))
    (declare (special *already-seen*))
    (labels 
	((amass-tree
	  (parents &optional already-seen)
	  (let (result this-item)
	    (dolist (parent parents)
	      (unless (member (pattern-caller-type parent)
			      types-to-ignore)
		(pushnew parent *already-seen*)
		(if (member parent already-seen)
		    (setq this-item nil) ; :ignore
		    (if compact 
			(multiple-value-setq (this-item already-seen)
			    (amass-tree (gethash parent database)
					(cons parent already-seen)))
			(setq this-item
			      (amass-tree (gethash parent database)
					  (cons parent already-seen)))))
		(setq parent (format nil "~S" parent))
		(when (consp parent) (setq parent (cons :xref-list parent)))
		(unless (eq this-item :ignore)
		  (push (if this-item
			    (list parent this-item)
			    parent) 
			result))))
	    (values result		;(reverse result)
		    already-seen))))
      (values (amass-tree parents already-seen)
	      *already-seen*))))

(defun find-roots-and-cycles (&optional (mode *default-graphing-mode*)
					(types-to-ignore *types-to-ignore*))
  "Returns a list of uncalled callers (roots) and called callers (potential
   cycles)."
  (let ((uncalled-callers nil)
	(called-callers nil)
	(database (ecase mode
		    (:call-graph   *callers-database*)
		    (:caller-graph *callees-database*)))
	(other-database (ecase mode
			  (:call-graph   *callees-database*)
			  (:caller-graph *callers-database*))))
    (maphash #'(lambda (name value)
		 (declare (ignore value))
		 (unless (member (pattern-caller-type name) 
				 types-to-ignore)
		   (if (gethash name database)
		       (push name called-callers)
		       (push name uncalled-callers))))
	     other-database)
    (values uncalled-callers called-callers)))

(defun make-caller-tree (&optional (mode *default-graphing-mode*)
				   (types-to-ignore *types-to-ignore*) compact)
  "Outputs list structure of a tree which roughly represents the possibly
   cyclical structure of the caller database.
   If mode is :call-graph, the children of a node are the functions it calls.
   If mode is :caller-graph, the children of a node are the functions that
   call it.
   If compact is T, tries to eliminate the already-seen nodes, so that
   the graph for a node is printed at most once. Otherwise it will duplicate
   the node's tree (except for cycles). This is usefull because the call tree
   is actually a directed graph, so we can either duplicate references or
   display only the first one."
  ;; Would be nice to print out line numbers and whenever we skip a duplicated
  ;; reference, print the line number of the full reference after the node.
  (multiple-value-bind (uncalled-callers called-callers)
      (find-roots-and-cycles mode types-to-ignore)
    (multiple-value-bind (trees already-seen)
	(gather-tree uncalled-callers nil mode types-to-ignore compact)
      (setq *last-caller-tree* trees)
      (let ((more-trees (gather-tree (set-difference called-callers
						     already-seen)
				     already-seen 
				     mode types-to-ignore compact)))
	(values trees more-trees)))))

(defvar *indent-amount* 3
  "Number of spaces to indent successive levels in PRINT-INDENTED-TREE.")

(defun print-indented-tree (trees &optional (indent 0))
  "Simple code to print out a list-structure tree (such as those created
   by make-caller-tree) as indented text."
  (when trees
    (dolist (tree trees)
      (cond ((and (listp tree) (eq (car tree) :xref-list))
	     (format t "~&~VT~A" indent (cdr tree)))
	    ((listp tree)
	     (format t "~&~VT~A" indent (car tree))
	     (print-indented-tree (cadr tree) (+ indent *indent-amount*)))
	    (t
	     (format t "~&~VT~A" indent tree))))))

(defun print-caller-trees (&key (mode *default-graphing-mode*)
				(types-to-ignore *types-to-ignore*)
				compact
				root-nodes)
  "Prints the calling trees (which may actually be a full graph and not
   necessarily a DAG) as indented text trees using PRINT-INDENTED-TREE.
   MODE is :call-graph for trees where the children of a node are the
   functions called by the node, or :caller-graph for trees where the
   children of a node are the functions the node calls. TYPES-TO-IGNORE
   is a list of funcall types (as specified in the patterns) to ignore
   in printing out the database. For example, '(:lisp) would ignore all
   calls to common lisp functions. COMPACT is a flag to tell the program
   to try to compact the trees a bit by not printing trees if they have
   already been seen. ROOT-NODES is a list of root nodes of trees to 
   display. If ROOT-NODES is nil, tries to find all root nodes in the
   database."
  (multiple-value-bind (rooted cycles)
      (if root-nodes
	  (values (gather-tree root-nodes nil mode types-to-ignore compact))
	  (make-caller-tree mode types-to-ignore compact))
    (when rooted
      (format t "~&Rooted calling trees:")
      (print-indented-tree rooted 2))
    (when cycles
      (when rooted      
	(format t "~2%"))
      (format t "~&Cyclic calling trees:")
      (print-indented-tree cycles 2))))


;;; ********************************
;;; Interface to PSGraph ***********
;;; ********************************
#|
;;; Interface to Bates' PostScript Graphing Utility
(load "/afs/cs/user/mkant/Lisp/PSGraph/psgraph")

(defparameter *postscript-output-directory* "")
(defun psgraph-xref (&key (mode *default-graphing-mode*)
			  (output-directory *postscript-output-directory*)
			  (types-to-ignore *types-to-ignore*)
			  (compact t)
			  (shrink t)
			  root-nodes
			  insert)
  ;; If root-nodes is a non-nil list, uses that list as the starting
  ;; position. Otherwise tries to find all roots in the database.
  (multiple-value-bind (rooted cycles)
      (if root-nodes
	  (values (gather-tree root-nodes nil mode types-to-ignore compact))
	  (make-caller-tree mode types-to-ignore compact))
    (psgraph-output (append rooted cycles) output-directory shrink insert)))

(defun psgraph-output (list-of-trees directory shrink &optional insert)
  (let ((psgraph:*fontsize* 9)
	(psgraph:*second-fontsize* 7)
;	(psgraph:*boxkind* "fill")
	(psgraph:*boxgray* "0") ; .8
	(psgraph:*edgewidth* "1")
	(psgraph:*edgegray* "0"))
    (labels ((stringify (thing)
		(cond ((stringp thing) (string-downcase thing))
		      ((symbolp thing) (string-downcase (symbol-name thing)))
		      ((and (listp thing) (eq (car thing) :xref-list))
		       (stringify (cdr thing)))
		      ((listp thing) (stringify (car thing)))
		      (t (string thing)))))
      (dolist (item list-of-trees)
	(let* ((fname (stringify item))
	       (filename (concatenate 'string directory
				      (string-trim '(#\: #\|) fname)
				      ".ps")))
	  (format t "~&Creating PostScript file ~S." filename)
	  (with-open-file (*standard-output* filename
					     :direction :output
					     :if-does-not-exist :create
					     :if-exists :supersede)
	    ;; Note that the #'eq prints the DAG as a tree. If
	    ;; you replace it with #'equal, it will print it as
	    ;; a DAG, which I think is slightly ugly.
	    (psgraph:psgraph item
			     #'caller-tree-children #'caller-info shrink
			     insert #'eq)))))))

(defun caller-tree-children (tree)
  (when (and tree (listp tree) (not (eq (car tree) :xref-list)))
    (cadr tree)))

(defun caller-tree-node (tree)
  (when tree
    (cond ((and (listp tree) (eq (car tree) :xref-list))
	   (cdr tree))
	  ((listp tree)
	   (car tree))
	  (t
	   tree))))

(defun caller-info (tree)
  (let ((node (caller-tree-node tree)))
    (list node)))
|#
#|
;;; Code to print out graphical trees of CLOS class hierarchies.
(defun print-class-hierarchy (&optional (start-class 'anything) 
					(file "classes.ps"))
  (let ((start (find-class start-class)))
    (when start
      (with-open-file (*standard-output* file :direction :output)
	(psgraph:psgraph start 
			 #'clos::class-direct-subclasses
			 #'(lambda (x) 
			     (list (format nil "~A" (clos::class-name x))))
			 t nil #'eq)))))

|#


;;; ****************************************************************
;;; Cross Referencing Patterns for Common Lisp *********************
;;; ****************************************************************
(clear-patterns)

;;; ********************************
;;; Pattern Substitutions **********
;;; ********************************
(define-pattern-substitution integer (:test #'integerp))
(define-pattern-substitution rational (:test #'rationalp))
(define-pattern-substitution symbol  (:test #'symbolp))
(define-pattern-substitution string  (:test #'stringp))
(define-pattern-substitution number  (:test #'numberp))
(define-pattern-substitution lambda-list
  ((:star var)
   (:optional (:eq &optional)
	      (:star (:or var
			  (var (:optional form (:optional var))))))
   (:optional (:eq &rest) var)
   (:optional (:eq &key) (:star (:or var
			       ((:or var
				     (keyword var))
				(:optional form (:optional var)))))
	      (:optional &allow-other-keys))
   (:optional (:eq &aux)
	      (:star (:or var
			  (var (:optional form)))))))
(define-pattern-substitution test form)
(define-pattern-substitution body
  ((:star (:or declaration documentation-string))
   (:star form)))
(define-pattern-substitution documentation-string string)
(define-pattern-substitution initial-value form)
(define-pattern-substitution tag symbol)
(define-pattern-substitution declaration ((:eq declare)(:rest :ignore)))
(define-pattern-substitution destination form)
(define-pattern-substitution control-string string)
(define-pattern-substitution format-arguments 
  ((:star form)))
(define-pattern-substitution fn
  (:or ((:eq quote) function) 
       ((:eq function) function)
       function))

;;; ********************************
;;; Caller Patterns ****************
;;; ********************************

;;; Types Related
(define-caller-pattern coerce (form :ignore) :lisp)
(define-caller-pattern type-of (form) :lisp)
(define-caller-pattern upgraded-array-element-type (:ignore) :lisp2)
(define-caller-pattern upgraded-complex-part-type (:ignore) :lisp2)

;;; Lambdas and Definitions
(define-variable-pattern lambda-list-keywords :lisp)
(define-variable-pattern lambda-parameters-limit :lisp)
(define-caller-pattern lambda (lambda-list (:rest body)) :lisp)

(define-caller-pattern defun 
  (name lambda-list
	(:star (:or documentation-string declaration))
	(:star form))
  :lisp)

;;; perhaps this should use VAR, instead of NAME
(define-caller-pattern defvar 
  (var (:optional initial-value (:optional documentation-string)))
  :lisp)
(define-caller-pattern defparameter
  (var initial-value (:optional documentation-string))
  :lisp)
(define-caller-pattern defconstant
  (var initial-value (:optional documentation-string))
  :lisp)

(define-caller-pattern eval-when
  (:ignore				; the situations
   (:star form))
  :lisp)

;;; Logical Values
(define-variable-pattern nil :lisp)
(define-variable-pattern t :lisp)

;;; Predicates
(define-caller-pattern typep (form form) :lisp)
(define-caller-pattern subtypep (form form) :lisp)

(define-caller-pattern null (form) :lisp)
(define-caller-pattern symbolp (form) :lisp)
(define-caller-pattern atom (form) :lisp)
(define-caller-pattern consp (form) :lisp)
(define-caller-pattern listp (form) :lisp)
(define-caller-pattern numberp (form) :lisp)
(define-caller-pattern integerp (form) :lisp)
(define-caller-pattern rationalp (form) :lisp)
(define-caller-pattern floatp (form) :lisp)
(define-caller-pattern realp (form) :lisp2)
(define-caller-pattern complexp (form) :lisp)
(define-caller-pattern characterp (form) :lisp)
(define-caller-pattern stringp (form) :lisp)
(define-caller-pattern bit-vector-p (form) :lisp)
(define-caller-pattern vectorp (form) :lisp)
(define-caller-pattern simple-vector-p (form) :lisp)
(define-caller-pattern simple-string-p (form) :lisp)
(define-caller-pattern simple-bit-vector-p (form) :lisp)
(define-caller-pattern arrayp (form) :lisp)
(define-caller-pattern packagep (form) :lisp)
(define-caller-pattern functionp (form) :lisp)
(define-caller-pattern compiled-function-p (form) :lisp)
(define-caller-pattern commonp (form) :lisp)

;;; Equality Predicates
(define-caller-pattern eq (form form) :lisp)
(define-caller-pattern eql (form form) :lisp)
(define-caller-pattern equal (form form) :lisp)
(define-caller-pattern equalp (form form) :lisp)

;;; Logical Operators
(define-caller-pattern not (form) :lisp)
(define-caller-pattern or ((:star form)) :lisp)
(define-caller-pattern and ((:star form)) :lisp)

;;; Reference

;;; Quote is a problem. In Defmacro & friends, we'd like to actually
;;; look at the argument, 'cause it hides internal function calls
;;; of the defmacro. 
(define-caller-pattern quote (:ignore) :lisp)

(define-caller-pattern function ((:or fn form)) :lisp)
(define-caller-pattern symbol-value (form) :lisp)
(define-caller-pattern symbol-function (form) :lisp)
(define-caller-pattern fdefinition (form) :lisp2)
(define-caller-pattern boundp (form) :lisp)
(define-caller-pattern fboundp (form) :lisp)
(define-caller-pattern special-form-p (form) :lisp)

;;; Assignment
(define-caller-pattern setq ((:star var form)) :lisp)
(define-caller-pattern psetq ((:star var form)) :lisp)
(define-caller-pattern set (form form) :lisp)
(define-caller-pattern makunbound (form) :lisp)
(define-caller-pattern fmakunbound (form) :lisp)

;;; Generalized Variables
(define-caller-pattern setf ((:star form form)) :lisp)
(define-caller-pattern psetf ((:star form form)) :lisp)
(define-caller-pattern shiftf ((:plus form) form) :lisp)
(define-caller-pattern rotatef ((:star form)) :lisp)
(define-caller-pattern define-modify-macro 
  (name
   lambda-list
   fn
   (:optional documentation-string))
  :lisp)
(define-caller-pattern defsetf 
  (:or (name name (:optional documentation-string))
       (name lambda-list (var)
	(:star (:or declaration documentation-string))
	(:star form)))
  :lisp)
(define-caller-pattern define-setf-method
  (name lambda-list
   (:star (:or declaration documentation-string))
   (:star form))
  :lisp)
(define-caller-pattern get-setf-method (form) :lisp)
(define-caller-pattern get-setf-method-multiple-value (form) :lisp)


;;; Function invocation
(define-caller-pattern apply (fn form (:star form)) :lisp)
(define-caller-pattern funcall (fn (:star form)) :lisp)


;;; Simple sequencing
(define-caller-pattern progn ((:star form)) :lisp)
(define-caller-pattern prog1 (form (:star form)) :lisp)
(define-caller-pattern prog2 (form form (:star form)) :lisp)

;;; Variable bindings
(define-caller-pattern let
  (((:star (:or var (var &optional form))))
   (:star declaration)
   (:star form))
  :lisp)
(define-caller-pattern let*
  (((:star (:or var (var &optional form))))
    (:star declaration)
    (:star form))
  :lisp)
(define-caller-pattern compiler-let
  (((:star (:or var (var form))))
    (:star form))
  :lisp)
(define-caller-pattern progv
  (form form (:star form)) :lisp)
(define-caller-pattern flet
  (((:star (name lambda-list 
		 (:star (:or declaration
			     documentation-string))
		 (:star form))))
   (:star form))
  :lisp)
(define-caller-pattern labels
  (((:star (name lambda-list 
		 (:star (:or declaration
			     documentation-string))
		 (:star form))))
   (:star form))
  :lisp)
(define-caller-pattern macrolet
  (((:star (name lambda-list 
		 (:star (:or declaration
			     documentation-string))
		 (:star form))))
   (:star form))
  :lisp)
(define-caller-pattern symbol-macrolet
  (((:star (var form))) (:star declaration) (:star form))
  :lisp2)

;;; Conditionals
(define-caller-pattern if (test form (:optional form)) :lisp)
(define-caller-pattern when (test (:star form)) :lisp)
(define-caller-pattern unless (test (:star form)) :lisp)
(define-caller-pattern cond ((:star (test (:star form)))) :lisp)
(define-caller-pattern case
  (form
   (:star ((:or symbol
		((:star symbol)))
	   (:star form)))) 
  :lisp)
(define-caller-pattern typecase (form (:star (symbol (:star form)))) 
  :lisp)

;;; Blocks and Exits
(define-caller-pattern block (name (:star form)) :lisp)
(define-caller-pattern return-from (function (:optional form)) :lisp)
(define-caller-pattern return ((:optional form)) :lisp)

;;; Iteration
(define-caller-pattern loop ((:star form)) :lisp)
(define-caller-pattern do
  (((:star (:or var
		(var (:optional form (:optional form)))))) ; init step
   (form (:star form)) ; end-test result
   (:star declaration)
   (:star (:or tag form)))		; statement
  :lisp)
(define-caller-pattern do*
  (((:star (:or var
		(var (:optional form (:optional form)))))) 
   (form (:star form))
   (:star declaration)
   (:star (:or tag form)))
  :lisp)
(define-caller-pattern dolist
  ((var form (:optional form))
   (:star declaration)
   (:star (:or tag form)))
  :lisp)
(define-caller-pattern dotimes
  ((var form (:optional form))
   (:star declaration)
   (:star (:or tag form)))
  :lisp)

;;; Mapping
(define-caller-pattern mapcar (fn form (:star form)) :lisp)
(define-caller-pattern maplist (fn form (:star form)) :lisp)
(define-caller-pattern mapc (fn form (:star form)) :lisp)
(define-caller-pattern mapl (fn form (:star form)) :lisp)
(define-caller-pattern mapcan (fn form (:star form)) :lisp)
(define-caller-pattern mapcon (fn form (:star form)) :lisp)

;;; The "Program Feature"
(define-caller-pattern tagbody ((:star (:or tag form))) :lisp)
(define-caller-pattern prog
  (((:star (:or var (var (:optional form)))))
   (:star declaration)
   (:star (:or tag form)))
  :lisp)
(define-caller-pattern prog*    
  (((:star (:or var (var (:optional form)))))
   (:star declaration)
   (:star (:or tag form)))
  :lisp)
(define-caller-pattern go (tag) :lisp)

;;; Multiple Values
(define-caller-pattern values ((:star form)) :lisp)
(define-variable-pattern multiple-values-limit :lisp)
(define-caller-pattern values-list (form) :lisp)
(define-caller-pattern multiple-value-list (form) :lisp)
(define-caller-pattern multiple-value-call (fn (:star form)) :lisp)
(define-caller-pattern multiple-value-prog1 (form (:star form)) :lisp)
(define-caller-pattern multiple-value-bind
  (((:star var)) form
   (:star declaration)
   (:star form))
  :lisp)
(define-caller-pattern multiple-value-setq (((:star var)) form) :lisp)
(define-caller-pattern nth-value (form form) :lisp2)

;;; Dynamic Non-Local Exits
(define-caller-pattern catch (tag (:star form)) :lisp)
(define-caller-pattern throw (tag form) :lisp)
(define-caller-pattern unwind-protect (form (:star form)) :lisp)

;;; Macros
(define-caller-pattern macro-function (form) :lisp)
(define-caller-pattern defmacro
  (name
   lambda-list
   (:star (:or declaration documentation-string))
   (:star form))
  :lisp)
(define-caller-pattern macroexpand (form (:optional :ignore)) :lisp)
(define-caller-pattern macroexpand-1 (form (:optional :ignore)) :lisp)
(define-variable-pattern *macroexpand-hook* :lisp)

;;; Destructuring
(define-caller-pattern destructuring-bind 
  (lambda-list form
	       (:star declaration)
	       (:star form))
  :lisp2)

;;; Compiler Macros
(define-caller-pattern define-compiler-macro
  (name lambda-list
	(:star (:or declaration documentation-string))
	(:star form))
  :lisp2)
(define-caller-pattern compiler-macro-function (form) :lisp2)
(define-caller-pattern compiler-macroexpand (form (:optional :ignore)) :lisp2)
1915 1916
(define-caller-pattern compiler-macroexpand-1 (form (:optional :ignore))
  :lisp2)
Helmut Eller's avatar
Helmut Eller committed
1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271

;;; Environments
(define-caller-pattern variable-information (form &optional :ignore) 
  :lisp2)
(define-caller-pattern function-information (fn &optional :ignore) :lisp2)
(define-caller-pattern declaration-information (form &optional :ignore) :lisp2)
(define-caller-pattern augment-environment (form &key (:star :ignore)) :lisp2)
(define-caller-pattern define-declaration 
  (name
   lambda-list
   (:star form)) 
  :lisp2)
(define-caller-pattern parse-macro (name lambda-list form) :lisp2)
(define-caller-pattern enclose (form &optional :ignore) :lisp2)


;;; Declarations
(define-caller-pattern declare ((:rest :ignore)) :lisp)
(define-caller-pattern proclaim ((:rest :ignore)) :lisp)
(define-caller-pattern locally ((:star declaration) (:star form)) :lisp)
(define-caller-pattern declaim ((:rest :ignore)) :lisp2)
(define-caller-pattern the (form form) :lisp)

;;; Symbols
(define-caller-pattern get (form form (:optional form)) :lisp)
(define-caller-pattern remprop (form form) :lisp)
(define-caller-pattern symbol-plist (form) :lisp)
(define-caller-pattern getf (form form (:optional form)) :lisp)
(define-caller-pattern remf (form form) :lisp)
(define-caller-pattern get-properties (form form) :lisp)

(define-caller-pattern symbol-name (form) :lisp)
(define-caller-pattern make-symbol (form) :lisp)
(define-caller-pattern copy-symbol (form (:optional :ignore)) :lisp)
(define-caller-pattern gensym ((:optional :ignore)) :lisp)
(define-variable-pattern *gensym-counter* :lisp2)
(define-caller-pattern gentemp ((:optional :ignore :ignore)) :lisp)
(define-caller-pattern symbol-package (form) :lisp)
(define-caller-pattern keywordp (form) :lisp)

;;; Packages
(define-variable-pattern *package* :lisp)
(define-caller-pattern make-package ((:rest :ignore)) :lisp)
(define-caller-pattern in-package ((:rest :ignore)) :lisp)
(define-caller-pattern find-package ((:rest :ignore)) :lisp)
(define-caller-pattern package-name ((:rest :ignore)) :lisp)
(define-caller-pattern package-nicknames ((:rest :ignore)) :lisp)
(define-caller-pattern rename-package ((:rest :ignore)) :lisp)
(define-caller-pattern package-use-list ((:rest :ignore)) :lisp)
(define-caller-pattern package-used-by-list ((:rest :ignore)) :lisp)
(define-caller-pattern package-shadowing-symbols ((:rest :ignore)) :lisp)
(define-caller-pattern list-all-packages () :lisp)
(define-caller-pattern delete-package ((:rest :ignore)) :lisp2)
(define-caller-pattern intern (form &optional :ignore) :lisp)
(define-caller-pattern find-symbol (form &optional :ignore) :lisp)
(define-caller-pattern unintern (form &optional :ignore) :lisp)

(define-caller-pattern export ((:or symbol ((:star symbol)))
			       &optional :ignore) :lisp)
(define-caller-pattern unexport ((:or symbol ((:star symbol)))
			       &optional :ignore) :lisp)
(define-caller-pattern import ((:or symbol ((:star symbol)))
			       &optional :ignore) :lisp)
(define-caller-pattern shadowing-import ((:or symbol ((:star symbol)))
			       &optional :ignore) :lisp)
(define-caller-pattern shadow ((:or symbol ((:star symbol)))
			       &optional :ignore) :lisp)

(define-caller-pattern use-package ((:rest :ignore)) :lisp)
(define-caller-pattern unuse-package ((:rest :ignore)) :lisp)
(define-caller-pattern defpackage (name (:rest :ignore)) :lisp2)
(define-caller-pattern find-all-symbols (form) :lisp)
(define-caller-pattern do-symbols 
  ((var (:optional form (:optional form)))
   (:star declaration) 
   (:star (:or tag form))) 
  :lisp)
(define-caller-pattern do-external-symbols 
  ((var (:optional form (:optional form)))
   (:star declaration) 
   (:star (:or tag form))) 
  :lisp)
(define-caller-pattern do-all-symbols 
  ((var (:optional form))
   (:star declaration) 
   (:star (:or tag form))) 
  :lisp)
(define-caller-pattern with-package-iterator
  ((name form (:plus :ignore))
   (:star form))
  :lisp2)

;;; Modules
(define-variable-pattern *modules* :lisp)
(define-caller-pattern provide (form) :lisp)
(define-caller-pattern require (form &optional :ignore) :lisp)


;;; Numbers
(define-caller-pattern zerop (form) :lisp)
(define-caller-pattern plusp (form) :lisp)
(define-caller-pattern minusp (form) :lisp)
(define-caller-pattern oddp (form) :lisp)
(define-caller-pattern evenp (form) :lisp)

(define-caller-pattern = (form (:star form)) :lisp)
(define-caller-pattern /= (form (:star form)) :lisp)
(define-caller-pattern > (form (:star form)) :lisp)
(define-caller-pattern < (form (:star form)) :lisp)
(define-caller-pattern <= (form (:star form)) :lisp)
(define-caller-pattern >= (form (:star form)) :lisp)

(define-caller-pattern max (form (:star form)) :lisp)
(define-caller-pattern min (form (:star form)) :lisp)

(define-caller-pattern - (form (:star form)) :lisp)
(define-caller-pattern + (form (:star form)) :lisp)
(define-caller-pattern * (form (:star form)) :lisp)
(define-caller-pattern / (form (:star form)) :lisp)
(define-caller-pattern 1+ (form) :lisp)
(define-caller-pattern 1- (form) :lisp)

(define-caller-pattern incf (form form) :lisp)
(define-caller-pattern decf (form form) :lisp)

(define-caller-pattern conjugate (form) :lisp)

(define-caller-pattern gcd ((:star form)) :lisp)
(define-caller-pattern lcm ((:star form)) :lisp)

(define-caller-pattern exp (form) :lisp)
(define-caller-pattern expt (form form) :lisp)
(define-caller-pattern log (form (:optional form)) :lisp)
(define-caller-pattern sqrt (form) :lisp)
(define-caller-pattern isqrt (form) :lisp)

(define-caller-pattern abs (form) :lisp)
(define-caller-pattern phase (form) :lisp)
(define-caller-pattern signum (form) :lisp)
(define-caller-pattern sin (form) :lisp)
(define-caller-pattern cos (form) :lisp)
(define-caller-pattern tan (form) :lisp)
(define-caller-pattern cis (form) :lisp)
(define-caller-pattern asin (form) :lisp)
(define-caller-pattern acos (form) :lisp)
(define-caller-pattern atan (form &optional form) :lisp)
(define-variable-pattern pi :lisp)

(define-caller-pattern sinh (form) :lisp)
(define-caller-pattern cosh (form) :lisp)
(define-caller-pattern tanh (form) :lisp)
(define-caller-pattern asinh (form) :lisp)
(define-caller-pattern acosh (form) :lisp)
(define-caller-pattern atanh (form) :lisp)

;;; Type Conversions and Extractions
(define-caller-pattern float (form (:optional form)) :lisp)
(define-caller-pattern rational (form) :lisp)
(define-caller-pattern rationalize (form) :lisp)
(define-caller-pattern numerator (form) :lisp)
(define-caller-pattern denominator (form) :lisp)

(define-caller-pattern floor (form (:optional form)) :lisp)
(define-caller-pattern ceiling (form (:optional form)) :lisp)
(define-caller-pattern truncate (form (:optional form)) :lisp)
(define-caller-pattern round (form (:optional form)) :lisp)

(define-caller-pattern mod (form form) :lisp)
(define-caller-pattern rem (form form) :lisp)

(define-caller-pattern ffloor (form (:optional form)) :lisp)
(define-caller-pattern fceiling (form (:optional form)) :lisp)
(define-caller-pattern ftruncate (form (:optional form)) :lisp)
(define-caller-pattern fround (form (:optional form)) :lisp)

(define-caller-pattern decode-float (form) :lisp)
(define-caller-pattern scale-float (form form) :lisp)
(define-caller-pattern float-radix (form) :lisp)
(define-caller-pattern float-sign (form (:optional form)) :lisp)
(define-caller-pattern float-digits (form) :lisp)
(define-caller-pattern float-precision (form) :lisp)
(define-caller-pattern integer-decode-float (form) :lisp)

(define-caller-pattern complex (form (:optional form)) :lisp)
(define-caller-pattern realpart (form) :lisp)
(define-caller-pattern imagpart (form) :lisp)

(define-caller-pattern logior ((:star form)) :lisp)
(define-caller-pattern logxor ((:star form)) :lisp)
(define-caller-pattern logand ((:star form)) :lisp)
(define-caller-pattern logeqv ((:star form)) :lisp)

(define-caller-pattern lognand (form form) :lisp)
(define-caller-pattern lognor (form form) :lisp)
(define-caller-pattern logandc1 (form form) :lisp)
(define-caller-pattern logandc2 (form form) :lisp)
(define-caller-pattern logorc1 (form form) :lisp)
(define-caller-pattern logorc2 (form form) :lisp)

(define-caller-pattern boole (form form form) :lisp)
(define-variable-pattern boole-clr :lisp)
(define-variable-pattern boole-set :lisp)
(define-variable-pattern boole-1 :lisp)
(define-variable-pattern boole-2 :lisp)
(define-variable-pattern boole-c1 :lisp)
(define-variable-pattern boole-c2 :lisp)
(define-variable-pattern boole-and :lisp)
(define-variable-pattern boole-ior :lisp)
(define-variable-pattern boole-xor :lisp)
(define-variable-pattern boole-eqv :lisp)
(define-variable-pattern boole-nand :lisp)
(define-variable-pattern boole-nor :lisp)
(define-variable-pattern boole-andc1 :lisp)
(define-variable-pattern boole-andc2 :lisp)
(define-variable-pattern boole-orc1 :lisp)
(define-variable-pattern boole-orc2 :lisp)

(define-caller-pattern lognot (form) :lisp)
(define-caller-pattern logtest (form form) :lisp)
(define-caller-pattern logbitp (form form) :lisp)
(define-caller-pattern ash (form form) :lisp)
(define-caller-pattern logcount (form) :lisp)
(define-caller-pattern integer-length (form) :lisp)

(define-caller-pattern byte (form form) :lisp)
(define-caller-pattern byte-size (form) :lisp)
(define-caller-pattern byte-position (form) :lisp)
(define-caller-pattern ldb (form form) :lisp)
(define-caller-pattern ldb-test (form form) :lisp)
(define-caller-pattern mask-field (form form) :lisp)
(define-caller-pattern dpb (form form form) :lisp)
(define-caller-pattern deposit-field (form form form) :lisp)

;;; Random Numbers
(define-caller-pattern random (form (:optional form)) :lisp)
(define-variable-pattern *random-state* :lisp)
(define-caller-pattern make-random-state ((:optional form)) :lisp)
(define-caller-pattern random-state-p (form) :lisp)

;;; Implementation Parameters
(define-variable-pattern most-positive-fixnum :lisp)
(define-variable-pattern most-negative-fixnum :lisp)
(define-variable-pattern most-positive-short-float :lisp)
(define-variable-pattern least-positive-short-float :lisp)
(define-variable-pattern least-negative-short-float :lisp)
(define-variable-pattern most-negative-short-float :lisp)
(define-variable-pattern most-positive-single-float :lisp)
(define-variable-pattern least-positive-single-float :lisp)
(define-variable-pattern least-negative-single-float :lisp)
(define-variable-pattern most-negative-single-float :lisp)
(define-variable-pattern most-positive-double-float :lisp)
(define-variable-pattern least-positive-double-float :lisp)
(define-variable-pattern least-negative-double-float :lisp)
(define-variable-pattern most-negative-double-float :lisp)
(define-variable-pattern most-positive-long-float :lisp)
(define-variable-pattern least-positive-long-float :lisp)
(define-variable-pattern least-negative-long-float :lisp)
(define-variable-pattern most-negative-long-float :lisp)
(define-variable-pattern least-positive-normalized-short-float :lisp2)
(define-variable-pattern least-negative-normalized-short-float :lisp2)
(define-variable-pattern least-positive-normalized-single-float :lisp2)
(define-variable-pattern least-negative-normalized-single-float :lisp2)
(define-variable-pattern least-positive-normalized-double-float :lisp2)
(define-variable-pattern least-negative-normalized-double-float :lisp2)
(define-variable-pattern least-positive-normalized-long-float :lisp2)
(define-variable-pattern least-negative-normalized-long-float :lisp2)
(define-variable-pattern short-float-epsilon :lisp)
(define-variable-pattern single-float-epsilon :lisp)
(define-variable-pattern double-float-epsilon :lisp)
(define-variable-pattern long-float-epsilon :lisp)
(define-variable-pattern short-float-negative-epsilon :lisp)
(define-variable-pattern single-float-negative-epsilon :lisp)
(define-variable-pattern double-float-negative-epsilon :lisp)
(define-variable-pattern long-float-negative-epsilon :lisp)

;;; Characters 
(define-variable-pattern char-code-limit :lisp)
(define-variable-pattern char-font-limit :lisp)
(define-variable-pattern char-bits-limit :lisp)
(define-caller-pattern standard-char-p (form) :lisp)
(define-caller-pattern graphic-char-p (form) :lisp)
(define-caller-pattern string-char-p (form) :lisp)
(define-caller-pattern alpha-char-p (form) :lisp)
(define-caller-pattern upper-case-p (form) :lisp)
(define-caller-pattern lower-case-p (form) :lisp)
(define-caller-pattern both-case-p (form) :lisp)
(define-caller-pattern digit-char-p (form (:optional form)) :lisp)
(define-caller-pattern alphanumericp (form) :lisp)

(define-caller-pattern char= ((:star form)) :lisp)
(define-caller-pattern char/= ((:star form)) :lisp)
(define-caller-pattern char< ((:star form)) :lisp)
(define-caller-pattern char> ((:star form)) :lisp)
(define-caller-pattern char<= ((:star form)) :lisp)
(define-caller-pattern char>= ((:star form)) :lisp)

(define-caller-pattern char-equal ((:star form)) :lisp)
(define-caller-pattern char-not-equal ((:star form)) :lisp)
(define-caller-pattern char-lessp ((:star form)) :lisp)
(define-caller-pattern char-greaterp ((:star form)) :lisp)
(define-caller-pattern char-not-greaterp ((:star form)) :lisp)
(define-caller-pattern char-not-lessp ((:star form)) :lisp)

(define-caller-pattern char-code (form) :lisp)
(define-caller-pattern char-bits (form) :lisp)
(define-caller-pattern char-font (form) :lisp)
(define-caller-pattern code-char (form (:optional form form)) :lisp)
(define-caller-pattern make-char (form (:optional form form)) :lisp)
(define-caller-pattern characterp (form) :lisp)
(define-caller-pattern char-upcase (form) :lisp)
(define-caller-pattern char-downcase (form) :lisp)
(define-caller-pattern digit-char (form (:optional form form)) :lisp)
(define-caller-pattern char-int (form) :lisp)
(define-caller-pattern int-char (form) :lisp)
(define-caller-pattern char-name (form) :lisp)
(define-caller-pattern name-char (form) :lisp)
(define-variable-pattern char-control-bit :lisp)
(define-variable-pattern char-meta-bit :lisp)
(define-variable-pattern char-super-bit :lisp)
(define-variable-pattern char-hyper-bit :lisp)
(define-caller-pattern char-bit (form form) :lisp)
(define-caller-pattern set-char-bit (form form form) :lisp)

;;; Sequences
(define-caller-pattern complement (fn) :lisp2)
(define-caller-pattern elt (form form) :lisp)
(define-caller-pattern subseq (form form &optional form) :lisp)
(define-caller-pattern copy-seq (form) :lisp)
(define-caller-pattern length (form) :lisp)
(define-caller-pattern reverse (form) :lisp)
(define-caller-pattern nreverse (form) :lisp)
(define-caller-pattern make-sequence (form form &key form) :lisp)

(define-caller-pattern concatenate (form (:star form)) :lisp)
(define-caller-pattern map (form fn form (:star form)) :lisp)
(define-caller-pattern map-into (form fn (:star form)) :lisp2)

(define-caller-pattern some (fn form (:star form)) :lisp)
(define-caller-pattern every (fn form (:star form)) :lisp)
(define-caller-pattern notany (fn form (:star form)) :lisp)
(define-caller-pattern notevery (fn form (:star form)) :lisp)

(define-caller-pattern reduce (fn form &key (:star form)) :lisp)
(define-caller-pattern fill (form form &key (:star form)) :lisp)
(define-caller-pattern replace (form form &key (:star form)) :lisp)
(define-caller-pattern remove (form form &key (:star form)) :lisp)
(define-caller-pattern remove-if (fn form &key (:star form)) :lisp)
(define-caller-pattern remove-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern delete (form form &key (:star form)) :lisp)
(define-caller-pattern delete-if (fn form &key (:star form)) :lisp)
(define-caller-pattern delete-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern remove-duplicates (form &key (:star form)) :lisp)
(define-caller-pattern delete-duplicates (form &key (:star form)) :lisp)
(define-caller-pattern substitute (form form form &key (:star form)) :lisp)
(define-caller-pattern substitute-if (form fn form &key (:star form)) :lisp)
2272 2273
(define-caller-pattern substitute-if-not (form fn form &key (:star form))
  :lisp)
Helmut Eller's avatar
Helmut Eller committed
2274 2275
(define-caller-pattern nsubstitute (form form form &key (:star form)) :lisp)
(define-caller-pattern nsubstitute-if (form fn form &key (:star form)) :lisp)
2276 2277
(define-caller-pattern nsubstitute-if-not (form fn form &key (:star form))
  :lisp)
Helmut Eller's avatar
Helmut Eller committed
2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508
(define-caller-pattern find (form form &key (:star form)) :lisp)
(define-caller-pattern find-if (fn form &key (:star form)) :lisp)
(define-caller-pattern find-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern position (form form &key (:star form)) :lisp)
(define-caller-pattern position-if (fn form &key (:star form)) :lisp)
(define-caller-pattern position-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern count (form form &key (:star form)) :lisp)
(define-caller-pattern count-if (fn form &key (:star form)) :lisp)
(define-caller-pattern count-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern mismatch (form form &key (:star form)) :lisp)
(define-caller-pattern search (form form &key (:star form)) :lisp)
(define-caller-pattern sort (form fn &key (:star form)) :lisp)
(define-caller-pattern stable-sort (form fn &key (:star form)) :lisp)
(define-caller-pattern merge (form form form fn &key (:star form)) :lisp)

;;; Lists
(define-caller-pattern car (form) :lisp)
(define-caller-pattern cdr (form) :lisp)
(define-caller-pattern caar (form) :lisp)
(define-caller-pattern cadr (form) :lisp)
(define-caller-pattern cdar (form) :lisp)
(define-caller-pattern cddr (form) :lisp)
(define-caller-pattern caaar (form) :lisp)
(define-caller-pattern caadr (form) :lisp)
(define-caller-pattern cadar (form) :lisp)
(define-caller-pattern caddr (form) :lisp)
(define-caller-pattern cdaar (form) :lisp)
(define-caller-pattern cdadr (form) :lisp)
(define-caller-pattern cddar (form) :lisp)
(define-caller-pattern cdddr (form) :lisp)
(define-caller-pattern caaaar (form) :lisp)
(define-caller-pattern caaadr (form) :lisp)
(define-caller-pattern caadar (form) :lisp)
(define-caller-pattern caaddr (form) :lisp)
(define-caller-pattern cadaar (form) :lisp)
(define-caller-pattern cadadr (form) :lisp)
(define-caller-pattern caddar (form) :lisp)
(define-caller-pattern cadddr (form) :lisp)
(define-caller-pattern cdaaar (form) :lisp)
(define-caller-pattern cdaadr (form) :lisp)
(define-caller-pattern cdadar (form) :lisp)
(define-caller-pattern cdaddr (form) :lisp)
(define-caller-pattern cddaar (form) :lisp)
(define-caller-pattern cddadr (form) :lisp)
(define-caller-pattern cdddar (form) :lisp)
(define-caller-pattern cddddr (form) :lisp)

(define-caller-pattern cons (form form) :lisp)
(define-caller-pattern tree-equal (form form &key (:star fn)) :lisp)
(define-caller-pattern endp (form) :lisp)
(define-caller-pattern list-length (form) :lisp)
(define-caller-pattern nth (form form) :lisp)

(define-caller-pattern first (form) :lisp)
(define-caller-pattern second (form) :lisp)
(define-caller-pattern third (form) :lisp)
(define-caller-pattern fourth (form) :lisp)
(define-caller-pattern fifth (form) :lisp)
(define-caller-pattern sixth (form) :lisp)
(define-caller-pattern seventh (form) :lisp)
(define-caller-pattern eighth (form) :lisp)
(define-caller-pattern ninth (form) :lisp)
(define-caller-pattern tenth (form) :lisp)

(define-caller-pattern rest (form) :lisp)
(define-caller-pattern nthcdr (form form) :lisp)
(define-caller-pattern last (form (:optional form)) :lisp)
(define-caller-pattern list ((:star form)) :lisp)
(define-caller-pattern list* ((:star form)) :lisp)
(define-caller-pattern make-list (form &key (:star form)) :lisp)
(define-caller-pattern append ((:star form)) :lisp)
(define-caller-pattern copy-list (form) :lisp)
(define-caller-pattern copy-alist (form) :lisp)
(define-caller-pattern copy-tree (form) :lisp)
(define-caller-pattern revappend (form form) :lisp)
(define-caller-pattern nconc ((:star form)) :lisp)
(define-caller-pattern nreconc (form form) :lisp)
(define-caller-pattern push (form form) :lisp)
(define-caller-pattern pushnew (form form &key (:star form)) :lisp)
(define-caller-pattern pop (form) :lisp)
(define-caller-pattern butlast (form (:optional form)) :lisp)
(define-caller-pattern nbutlast (form (:optional form)) :lisp)
(define-caller-pattern ldiff (form form) :lisp)
(define-caller-pattern rplaca (form form) :lisp)
(define-caller-pattern rplacd (form form) :lisp)

(define-caller-pattern subst (form form form &key (:star form)) :lisp)
(define-caller-pattern subst-if (form fn form &key (:star form)) :lisp)
(define-caller-pattern subst-if-not (form fn form &key (:star form)) :lisp)
(define-caller-pattern nsubst (form form form &key (:star form)) :lisp)
(define-caller-pattern nsubst-if (form fn form &key (:star form)) :lisp)
(define-caller-pattern nsubst-if-not (form fn form &key (:star form)) :lisp)
(define-caller-pattern sublis (form form &key (:star form)) :lisp)
(define-caller-pattern nsublis (form form &key (:star form)) :lisp)
(define-caller-pattern member (form form &key (:star form)) :lisp)
(define-caller-pattern member-if (fn form &key (:star form)) :lisp)
(define-caller-pattern member-if-not (fn form &key (:star form)) :lisp)

(define-caller-pattern tailp (form form) :lisp)
(define-caller-pattern adjoin (form form &key (:star form)) :lisp)
(define-caller-pattern union (form form &key (:star form)) :lisp)
(define-caller-pattern nunion (form form &key (:star form)) :lisp)
(define-caller-pattern intersection (form form &key (:star form)) :lisp)
(define-caller-pattern nintersection (form form &key (:star form)) :lisp)
(define-caller-pattern set-difference (form form &key (:star form)) :lisp)
(define-caller-pattern nset-difference (form form &key (:star form)) :lisp)
(define-caller-pattern set-exclusive-or (form form &key (:star form)) :lisp)
(define-caller-pattern nset-exclusive-or (form form &key (:star form)) :lisp)
(define-caller-pattern subsetp (form form &key (:star form)) :lisp)

(define-caller-pattern acons (form form form) :lisp)
(define-caller-pattern pairlis (form form (:optional form)) :lisp)
(define-caller-pattern assoc (form form &key (:star form)) :lisp)
(define-caller-pattern assoc-if (fn form) :lisp)
(define-caller-pattern assoc-if-not (fn form) :lisp)
(define-caller-pattern rassoc (form form &key (:star form)) :lisp)
(define-caller-pattern rassoc-if (fn form &key (:star form)) :lisp)
(define-caller-pattern rassoc-if-not (fn form &key (:star form)) :lisp)

;;; Hash Tables
(define-caller-pattern make-hash-table (&key (:star form)) :lisp)
(define-caller-pattern hash-table-p (form) :lisp)
(define-caller-pattern gethash (form form (:optional form)) :lisp)
(define-caller-pattern remhash (form form) :lisp)
(define-caller-pattern maphash (fn form) :lisp)
(define-caller-pattern clrhash (form) :lisp)
(define-caller-pattern hash-table-count (form) :lisp)
(define-caller-pattern with-hash-table-iterator
  ((name form) (:star form)) :lisp2)
(define-caller-pattern hash-table-rehash-size (form) :lisp2)
(define-caller-pattern hash-table-rehash-threshold (form) :lisp2)
(define-caller-pattern hash-table-size (form) :lisp2)
(define-caller-pattern hash-table-test (form) :lisp2)
(define-caller-pattern sxhash (form) :lisp)

;;; Arrays
(define-caller-pattern make-array (form &key (:star form)) :lisp)
(define-variable-pattern array-rank-limit :lisp)
(define-variable-pattern array-dimension-limit :lisp)
(define-variable-pattern array-total-size-limit :lisp)
(define-caller-pattern vector ((:star form)) :lisp)
(define-caller-pattern aref (form (:star form)) :lisp)
(define-caller-pattern svref (form form) :lisp)
(define-caller-pattern array-element-type (form) :lisp)
(define-caller-pattern array-rank (form) :lisp)
(define-caller-pattern array-dimension (form form) :lisp)
(define-caller-pattern array-dimensions (form) :lisp)
(define-caller-pattern array-total-size (form) :lisp)
(define-caller-pattern array-in-bounds-p (form (:star form)) :lisp)
(define-caller-pattern array-row-major-index (form (:star form)) :lisp)
(define-caller-pattern row-major-aref (form form) :lisp2)
(define-caller-pattern adjustable-array-p (form) :lisp)

(define-caller-pattern bit (form (:star form)) :lisp)
(define-caller-pattern sbit (form (:star form)) :lisp)

(define-caller-pattern bit-and (form form (:optional form)) :lisp)
(define-caller-pattern bit-ior (form form (:optional form)) :lisp)
(define-caller-pattern bit-xor (form form (:optional form)) :lisp)
(define-caller-pattern bit-eqv (form form (:optional form)) :lisp)
(define-caller-pattern bit-nand (form form (:optional form)) :lisp)
(define-caller-pattern bit-nor (form form (:optional form)) :lisp)
(define-caller-pattern bit-andc1 (form form (:optional form)) :lisp)
(define-caller-pattern bit-andc2 (form form (:optional form)) :lisp)
(define-caller-pattern bit-orc1 (form form (:optional form)) :lisp)
(define-caller-pattern bit-orc2 (form form (:optional form)) :lisp)
(define-caller-pattern bit-not (form (:optional form)) :lisp)

(define-caller-pattern array-has-fill-pointer-p (form) :lisp)
(define-caller-pattern fill-pointer (form) :lisp)
(define-caller-pattern vector-push (form form) :lisp)
(define-caller-pattern vector-push-extend (form form (:optional form)) :lisp)
(define-caller-pattern vector-pop (form) :lisp)
(define-caller-pattern adjust-array (form form &key (:star form)) :lisp)

;;; Strings
(define-caller-pattern char (form form) :lisp)
(define-caller-pattern schar (form form) :lisp)
(define-caller-pattern string= (form form &key (:star form)) :lisp)
(define-caller-pattern string-equal (form form &key (:star form)) :lisp)
(define-caller-pattern string< (form form &key (:star form)) :lisp)
(define-caller-pattern string> (form form &key (:star form)) :lisp)
(define-caller-pattern string<= (form form &key (:star form)) :lisp)
(define-caller-pattern string>= (form form &key (:star form)) :lisp)
(define-caller-pattern string/= (form form &key (:star form)) :lisp)
(define-caller-pattern string-lessp (form form &key (:star form)) :lisp)
(define-caller-pattern string-greaterp (form form &key (:star form)) :lisp)
(define-caller-pattern string-not-greaterp (form form &key (:star form)) :lisp)
(define-caller-pattern string-not-lessp (form form &key (:star form)) :lisp)
(define-caller-pattern string-not-equal (form form &key (:star form)) :lisp)

(define-caller-pattern make-string (form &key (:star form)) :lisp)
(define-caller-pattern string-trim (form form) :lisp)
(define-caller-pattern string-left-trim (form form) :lisp)
(define-caller-pattern string-right-trim (form form) :lisp)
(define-caller-pattern string-upcase (form &key (:star form)) :lisp)
(define-caller-pattern string-downcase (form &key (:star form)) :lisp)
(define-caller-pattern string-capitalize (form &key (:star form)) :lisp)
(define-caller-pattern nstring-upcase (form &key (:star form)) :lisp)
(define-caller-pattern nstring-downcase (form &key (:star form)) :lisp)
(define-caller-pattern nstring-capitalize (form &key (:star form)) :lisp)
(define-caller-pattern string (form) :lisp)

;;; Structures
(define-caller-pattern defstruct 
  ((:or name (name (:rest :ignore)))
   (:optional documentation-string)
   (:plus :ignore))
  :lisp)

;;; The Evaluator
(define-caller-pattern eval (form) :lisp)
(define-variable-pattern *evalhook* :lisp)
(define-variable-pattern *applyhook* :lisp)
(define-caller-pattern evalhook (form fn fn &optional :ignore) :lisp)
(define-caller-pattern applyhook (fn form fn fn &optional :ignore) :lisp)
(define-caller-pattern constantp (form) :lisp)

;;; Streams
(define-variable-pattern *standard-input* :lisp)
(define-variable-pattern *standard-output* :lisp)
(define-variable-pattern *error-output* :lisp)
(define-variable-pattern *query-io* :lisp)
(define-variable-pattern *debug-io* :lisp)
(define-variable-pattern *terminal-io* :lisp)
(define-variable-pattern *trace-output* :lisp)
(define-caller-pattern make-synonym-stream (symbol) :lisp)
(define-caller-pattern make-broadcast-stream ((:star form)) :lisp)
(define-caller-pattern make-concatenated-stream ((:star form)) :lisp)
(define-caller-pattern make-two-way-stream (form form) :lisp)
(define-caller-pattern make-echo-stream (form form) :lisp)
2509 2510
(define-caller-pattern make-string-input-stream (form &optional form form)
  :lisp)
Helmut Eller's avatar
Helmut Eller committed
2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553
(define-caller-pattern make-string-output-stream (&key (:star form)) :lisp)
(define-caller-pattern get-output-stream-string (form) :lisp)

(define-caller-pattern with-open-stream
  ((var form)
   (:star declaration)
   (:star form))
  :lisp)

(define-caller-pattern with-input-from-string
  ((var form &key (:star form))
   (:star declaration)
   (:star form))
  :lisp)

(define-caller-pattern with-output-to-string
  ((var (:optional form))
   (:star declaration)
   (:star form))
  :lisp)
(define-caller-pattern streamp (form) :lisp)
(define-caller-pattern open-stream-p (form) :lisp2)
(define-caller-pattern input-stream-p (form) :lisp)
(define-caller-pattern output-stream-p (form) :lisp)
(define-caller-pattern stream-element-type (form) :lisp)
(define-caller-pattern close (form (:rest :ignore)) :lisp)
(define-caller-pattern broadcast-stream-streams (form) :lisp2)
(define-caller-pattern concatenated-stream-streams (form) :lisp2)
(define-caller-pattern echo-stream-input-stream (form) :lisp2)
(define-caller-pattern echo-stream-output-stream (form) :lisp2)
(define-caller-pattern synonym-stream-symbol (form) :lisp2)
(define-caller-pattern two-way-stream-input-stream (form) :lisp2)
(define-caller-pattern two-way-stream-output-stream (form) :lisp2)
(define-caller-pattern interactive-stream-p (form) :lisp2)
(define-caller-pattern stream-external-format (form) :lisp2)

;;; Reader
(define-variable-pattern *read-base* :lisp)
(define-variable-pattern *read-suppress* :lisp)
(define-variable-pattern *read-eval* :lisp2)
(define-variable-pattern *readtable* :lisp)
(define-caller-pattern copy-readtable (&optional form form) :lisp)
(define-caller-pattern readtablep (form) :lisp)
2554 2555
(define-caller-pattern set-syntax-from-char (form form &optional form form)
  :lisp)
Helmut Eller's avatar
Helmut Eller committed
2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605
(define-caller-pattern set-macro-character (form fn &optional form) :lisp)
(define-caller-pattern get-macro-character (form (:optional form)) :lisp)
(define-caller-pattern make-dispatch-macro-character (form &optional form form)
  :lisp)
(define-caller-pattern set-dispatch-macro-character
  (form form fn (:optional form)) :lisp)
(define-caller-pattern get-dispatch-macro-character
  (form form (:optional form)) :lisp)
(define-caller-pattern readtable-case (form) :lisp2)
(define-variable-pattern *print-readably* :lisp2)
(define-variable-pattern *print-escape* :lisp)
(define-variable-pattern *print-pretty* :lisp)
(define-variable-pattern *print-circle* :lisp)
(define-variable-pattern *print-base* :lisp)
(define-variable-pattern *print-radix* :lisp)
(define-variable-pattern *print-case* :lisp)
(define-variable-pattern *print-gensym* :lisp)
(define-variable-pattern *print-level* :lisp)
(define-variable-pattern *print-length* :lisp)
(define-variable-pattern *print-array* :lisp)
(define-caller-pattern with-standard-io-syntax 
  ((:star declaration)
   (:star form))
  :lisp2)

(define-caller-pattern read (&optional form form form form) :lisp)
(define-variable-pattern *read-default-float-format* :lisp)
(define-caller-pattern read-preserving-whitespace
  (&optional form form form form) :lisp)
(define-caller-pattern read-delimited-list (form &optional form form) :lisp)
(define-caller-pattern read-line (&optional form form form form) :lisp)
(define-caller-pattern read-char (&optional form form form form) :lisp)
(define-caller-pattern unread-char (form (:optional form)) :lisp)
(define-caller-pattern peek-char (&optional form form form form) :lisp)
(define-caller-pattern listen ((:optional form)) :lisp)
(define-caller-pattern read-char-no-hang ((:star form)) :lisp)
(define-caller-pattern clear-input ((:optional form)) :lisp)
(define-caller-pattern read-from-string (form (:star form)) :lisp)
(define-caller-pattern parse-integer (form &rest :ignore) :lisp)
(define-caller-pattern read-byte ((:star form)) :lisp)

(define-caller-pattern write (form &key (:star form)) :lisp)
(define-caller-pattern prin1 (form (:optional form)) :lisp)
(define-caller-pattern print (form (:optional form)) :lisp)
(define-caller-pattern pprint (form (:optional form)) :lisp)
(define-caller-pattern princ (form (:optional form)) :lisp)
(define-caller-pattern write-to-string (form &key (:star form)) :lisp)
(define-caller-pattern prin1-to-string (form) :lisp)
(define-caller-pattern princ-to-string (form) :lisp)
(define-caller-pattern write-char (form (:optional form)) :lisp)
2606 2607 2608 2609
(define-caller-pattern write-string (form &optional form &key (:star form))
  :lisp)
(define-caller-pattern write-line (form &optional form &key (:star form))
  :lisp)
Helmut Eller's avatar
Helmut Eller committed
2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636
(define-caller-pattern terpri ((:optional form)) :lisp)
(define-caller-pattern fresh-line ((:optional form)) :lisp)
(define-caller-pattern finish-output ((:optional form)) :lisp)
(define-caller-pattern force-output ((:optional form)) :lisp)
(define-caller-pattern clear-output ((:optional form)) :lisp)
(define-caller-pattern print-unreadable-object 
  ((form form &key (:star form))
   (:star declaration)
   (:star form))
  :lisp2)
(define-caller-pattern write-byte (form form) :lisp)
(define-caller-pattern format
  (destination
   control-string
   (:rest format-arguments))
  :lisp)

(define-caller-pattern y-or-n-p (control-string (:star form)) :lisp)
(define-caller-pattern yes-or-no-p (control-string (:star form)) :lisp)

;;; Pathnames
(define-caller-pattern wild-pathname-p (form &optional form) :lisp2)
(define-caller-pattern pathname-match-p (form form) :lisp2)
(define-caller-pattern translate-pathname (form form form &key (:star form))
  :lisp2)

(define-caller-pattern logical-pathname (form) :lisp2)
2637 2638
(define-caller-pattern translate-logical-pathname (form &key (:star form))
  :lisp2)
Helmut Eller's avatar
Helmut Eller committed
2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776
(define-caller-pattern logical-pathname-translations (form) :lisp2)
(define-caller-pattern load-logical-pathname-translations (form) :lisp2)
(define-caller-pattern compile-file-pathname (form &key form) :lisp2)

(define-caller-pattern pathname (form) :lisp)
(define-caller-pattern truename (form) :lisp)
(define-caller-pattern parse-namestring ((:star form)) :lisp)
(define-caller-pattern merge-pathnames ((:star form)) :lisp)
(define-variable-pattern *default-pathname-defaults* :lisp)
(define-caller-pattern make-pathname ((:star form)) :lisp)
(define-caller-pattern pathnamep (form) :lisp)
(define-caller-pattern pathname-host (form) :lisp)
(define-caller-pattern pathname-device (form) :lisp)
(define-caller-pattern pathname-directory (form) :lisp)
(define-caller-pattern pathname-name (form) :lisp)
(define-caller-pattern pathname-type (form) :lisp)
(define-caller-pattern pathname-version (form) :lisp)
(define-caller-pattern namestring (form) :lisp)
(define-caller-pattern file-namestring (form) :lisp)
(define-caller-pattern directory-namestring (form) :lisp)
(define-caller-pattern host-namestring (form) :lisp)
(define-caller-pattern enough-namestring (form (:optional form)) :lisp)
(define-caller-pattern user-homedir-pathname (&optional form) :lisp)
(define-caller-pattern open (form &key (:star form)) :lisp)
(define-caller-pattern with-open-file
  ((var form (:rest :ignore))
   (:star declaration)
   (:star form))
 :lisp)

(define-caller-pattern rename-file (form form) :lisp)
(define-caller-pattern delete-file (form) :lisp)
(define-caller-pattern probe-file (form) :lisp)
(define-caller-pattern file-write-date (form) :lisp)
(define-caller-pattern file-author (form) :lisp)
(define-caller-pattern file-position (form (:optional form)) :lisp)
(define-caller-pattern file-length (form) :lisp)
(define-caller-pattern file-string-length (form form) :lisp2)
(define-caller-pattern load (form &key (:star form)) :lisp)
(define-variable-pattern *load-verbose* :lisp)
(define-variable-pattern *load-print* :lisp2)
(define-variable-pattern *load-pathname* :lisp2)
(define-variable-pattern *load-truename* :lisp2)
(define-caller-pattern make-load-form (form) :lisp2)
(define-caller-pattern make-load-form-saving-slots (form &optional form)
  :lisp2)
(define-caller-pattern directory (form &key (:star form)) :lisp)

;;; Errors
(define-caller-pattern error (form (:star form)) :lisp)
(define-caller-pattern cerror (form form (:star form)) :lisp)
(define-caller-pattern warn (form (:star form)) :lisp)
(define-variable-pattern *break-on-warnings* :lisp)
(define-caller-pattern break (&optional form (:star form)) :lisp)
(define-caller-pattern check-type (form form (:optional form)) :lisp)
(define-caller-pattern assert 
  (form
   (:optional ((:star var))
	      (:optional form (:star form)))) 
  :lisp)
(define-caller-pattern etypecase (form (:star (symbol (:star form)))) :lisp)
(define-caller-pattern ctypecase (form (:star (symbol (:star form)))) :lisp)
(define-caller-pattern ecase
  (form
   (:star ((:or symbol ((:star symbol)))
	   (:star form))))
  :lisp)
(define-caller-pattern ccase 
  (form
   (:star ((:or symbol ((:star symbol)))
	   (:star form))))
  :lisp)

;;; The Compiler
(define-caller-pattern compile (form (:optional form)) :lisp)
(define-caller-pattern compile-file (form &key (:star form)) :lisp)
(define-variable-pattern *compile-verbose* :lisp2)
(define-variable-pattern *compile-print* :lisp2)
(define-variable-pattern *compile-file-pathname* :lisp2)
(define-variable-pattern *compile-file-truename* :lisp2)
(define-caller-pattern load-time-value (form (:optional form)) :lisp2)
(define-caller-pattern disassemble (form) :lisp)
(define-caller-pattern function-lambda-expression (fn) :lisp2)
(define-caller-pattern with-compilation-unit (((:star :ignore)) (:star form)) 
  :lisp2)

;;; Documentation
(define-caller-pattern documentation (form form) :lisp)
(define-caller-pattern trace ((:star form)) :lisp)
(define-caller-pattern untrace ((:star form)) :lisp)
(define-caller-pattern step (form) :lisp)
(define-caller-pattern time (form) :lisp)
(define-caller-pattern describe (form &optional form) :lisp)
(define-caller-pattern describe-object (form &optional form) :lisp2)
(define-caller-pattern inspect (form) :lisp)
(define-caller-pattern room ((:optional form)) :lisp)
(define-caller-pattern ed ((:optional form)) :lisp)
(define-caller-pattern dribble ((:optional form)) :lisp)
(define-caller-pattern apropos (form (:optional form)) :lisp)
(define-caller-pattern apropos-list (form (:optional form)) :lisp)
(define-caller-pattern get-decoded-time () :lisp)
(define-caller-pattern get-universal-time () :lisp)
(define-caller-pattern decode-universal-time (form &optional form) :lisp)
(define-caller-pattern encode-universal-time 
  (form form form form form form &optional form) :lisp)
(define-caller-pattern get-internal-run-time () :lisp)
(define-caller-pattern get-internal-real-time () :lisp)
(define-caller-pattern sleep (form) :lisp)

(define-caller-pattern lisp-implementation-type () :lisp)
(define-caller-pattern lisp-implementation-version () :lisp)
(define-caller-pattern machine-type () :lisp)
(define-caller-pattern machine-version () :lisp)
(define-caller-pattern machine-instance () :lisp)
(define-caller-pattern software-type () :lisp)
(define-caller-pattern software-version () :lisp)
(define-caller-pattern short-site-name () :lisp)
(define-caller-pattern long-site-name () :lisp)
(define-variable-pattern *features* :lisp)

(define-caller-pattern identity (form) :lisp)

;;; Pretty Printing
(define-variable-pattern *print-pprint-dispatch* :lisp2)
(define-variable-pattern *print-right-margin* :lisp2)
(define-variable-pattern *print-miser-width* :lisp2)
(define-variable-pattern *print-lines* :lisp2)
(define-caller-pattern pprint-newline (form &optional form) :lisp2)
(define-caller-pattern pprint-logical-block
  ((var form &key (:star form))
   (:star form))
  :lisp2)
(define-caller-pattern pprint-exit-if-list-exhausted () :lisp2)
(define-caller-pattern pprint-pop () :lisp2)
(define-caller-pattern pprint-indent (form form &optional form) :lisp2)
(define-caller-pattern pprint-tab (form form form &optional form) :lisp2)
(define-caller-pattern pprint-fill (form form &optional form form) :lisp2)
(define-caller-pattern pprint-linear (form form &optional form form) :lisp2)
2777 2778
(define-caller-pattern pprint-tabular (form form &optional form form form)
  :lisp2)
Helmut Eller's avatar
Helmut Eller committed
2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833