specials.lisp

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-ADD-ONS; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/specials.lisp,v 1.41 2015/03/06 12:54:25 edi Exp $

;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; This code copied almost verbatim from SLIME, see
;;; <http://common-lisp.net/project/slime/>

(in-package :lw-add-ons)

(defvar *show-doc-string-when-showing-arglist* nil
  "Whether the editor command `Insert Space and Show Arglist`
is supposed to show the documentation string as well.")

(defvar *max-completions-to-show* 14
  "The maximum number of possible completions shown in the echo
area by \"Complete Symbol Without Dialog.\"")

(defvar *insert-right-parenthesis-if-no-args* t
  "Whether \"Complete Symbol Without Dialog\" should insert a
right parenthesis if the function is known to have an empty
argument list.")

(defvar *mop-page* "c:/home/lisp/doc/mop/dictionary.html"
  "A pathname specifier denoting the location of the dictionary
page from the `AMOP` `HTML` version. The page is available online at
<http://www.lisp.org/mop/dictionary.html>

**TODO:** A link above does not work anymore. We need to find another source.")

(defvar *completion-match-function* 'compound-prefix-match
  "The function used by **\"Complete Symbol Without Dialog\"** to
   check possible completions.  Should be a designator for a
   function of two arguments and return true iff the second argument
   is a possible completion of the first one.")

(defvar *use-abbreviated-complete-symbol* t
  "Whether **\"Indent And Complete Symbol\"** should call
   **\"Abbreviated Complete Symbol\"** \(only available in LispWorks 5.1 or higher) instead
   of **\"Complete Symbol Without Dialog\"**.")

(defvar *make-backup-filename-function* nil
  "If the value of this variable is not NIL, then it should be a
designator for a function of one argument which accepts a pathname and
returns a pathname.  LispWork's own EDITOR::MAKE-BACKUP-FILENAME
function will be replaced with this one in this case.")

(defvar *backup-directory*
  #+(or :win32 :macosx)
  (merge-pathnames "LW-ADD-ONS/Backups/"
                   (probe-file
                    (sys:get-folder-path #+:win32 :local-appdata
                                         #+:macosx :my-appsupport
                                         :create t)))
  #+:linux #p"~/.lw-backups/"
  "The directory where backups are stored if the value of
*MAKE-BACKUP-FILENAME-FUNCTION* denotes the function
'MAKE-BACKUP-FILENAME-USING-BACKUP-DIRECTORY.  It is recommended that
you dont't use this directory for other purposes.")

(defvar *swank-loader-pathname* #p"c:/emacs/site-lisp/slime/swank-loader.lisp"
  "A pathname specifier denoting the location of the
`swank-loader.lisp' file.  Only needed if one wants to start the
Swank server from LW - see function START-SWANK-SERVER.")

(defvar *translate-asdf-systems* t
  "Whether ASDF systems should be automatically converted to LispWorks
Common Defsystem systems.")

(defvar *max-info-length* 400
  "The maximum length \(in characters) of a message shown by
SHOW-INFO \(unless FULL-LENGTH-P is true).")

(defvar *apropos-max-search-list-length* 20
  "The maximal number of items in the CAPI:TEXT-INPUT-CHOICE in the
Apropos Dialog.")

(defvar *apropos-max-string-length* 50
  "The maximum amount of characters to show when an object is printed
in the pull down menu of an Apropos Dialog.")

(defvar *apropos-print-length* 5
  "*PRINT-LENGTH* is bound to this value while the Apropos Dialog
displays objects.")

(defvar *apropos-print-level* 5
  "*PRINT-LEVEL* is bound to this value while the Apropos Dialog
displays objects.")

(defvar *product-registry-path* '("Software" "Edi Weitz" "LW-ADD-ONS")
  "The product registry path used for storing and retrieving user
preferences.")

(defconstant +apropos-headline+ '("Symbol Name" "Package" "Fun" "Var" "Class" "Exp")
  "The headline of the Apropos Dialog's result panel.")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *use-quicklisp-for-shortcut-l* t
    "Whether listener shortcuts should prefer Quicklisp."))

(defvar *listener-shortcuts*
  (load-time-value
   (append
    (list '("c" . "Compile ASDF System")
          '("t" . "Test ASDF System")
          '("p" . "Change Package")
          '("i" . "Change Package")
          '("cd" . "Change Directory")
          '("pwd" . "Show Directory")
          '("q" . "Quit")
          '("s" . "Quit"))
    #-:quicklisp
    (list '("l" . "Load ASDF System"))
    #+:quicklisp
    (if *use-quicklisp-for-shortcut-l*
      (list '("a" . "Load ASDF System") '("l" . "Quickload Library"))
      (list '("l" . "Load ASDF System") '("ql" . "Quickload Library")))))
  "An alist of commands that can be invoked with \"Invoke Listener
Shortcut\" or with comma at beginning of listener line, each one
preceded by a shortcut.")

(defvar *swank-started-p* nil
  "Whether START-SWANK-SERVER has already been called.")

(defvar *doc-hash* (make-hash-table :test #'equalp)
  "A hash table which maps entries \(mostly strings) for the
\"Meta Documentation\" command to URLs.")
(defvar *doc-hash-entries* nil
  "The list of all keys of *DOC-HASH*.")

(defvar *hyperdoc-packages* nil
  "Temporarily set to a list of all packages that have a symbol named
HYPERDOC-LOOKUP during execution of \"Meta Documentation\" command.")
(defvar *doc-entries* nil
  "Temporarily set to a list of all candidates during completion in
\"Meta Documentation\" command.")

(defconstant +cl-user-package+ (load-time-value (find-package :cl-user))
  "The CL-USER package.")
(defconstant +keyword-package+ (load-time-value (find-package :keyword))
  "The KEYWORD package.")

(defvar *all-asdf-systems* nil
  "Temporarily bound to a list of all ASDF system names while
prompting for a system name.")

(defvar *search-end* nil
  "If this variable is bound to a true value then it should be a
pointer and EDITOR::FIND-PATTERN \(and EDITOR:I-FIND-PATTERN) won't
search beyond this point \(unless called with a non-NIL LIMIT
argument).")

(defvar *change-default-for-file-prompt* nil
  "If this variable is bound to a a true value then the function
EDITOR:PROMPT-FOR-FILE will use the full file name \(as opposed
to the file's location) as its default string \(unless a default
string was explicitly specified or the DEFAULT argument is a
string).")

#+:editor-does-not-have-go-back
(defvar *find-definitions-stack* nil
  "Stack of previous positions \(points) within the editor, used by
new \"Pop Definitions Stack\" command.  See docs.")

(defvar *lw-add-ons-break-on-signals* nil
  "The value *BREAK-ON-SIGNALS* is bound to in IGNORE-ERRORS*.  Set
this to NIL to debug LW-ADD-ONS.")

(defvar *temp-files* nil
  "A list of temporary files which should be deleted when the image
exits.")

(defvar *clhs-add-ons*
  '(("~C: Character" "22_caa.htm")
    ("~%: Newline" "22_cab.htm")
    ("~&: Freshline" "22_cac.htm")
    ("~|: Page" "22_cad.htm")
    ("~~: Tilde" "22_cae.htm")
    ("~R: Radix" "22_cba.htm")
    ("~D: Decimal" "22_cbb.htm")
    ("~B: Binary" "22_cbc.htm")
    ("~O: Octal" "22_cbd.htm")
    ("~X: Hexadecimal" "22_cbe.htm")
    ("~F: Fixed-Format Floating-Point" "22_cca.htm")
    ("~E: Exponential Floating-Point" "22_ccb.htm")
    ("~G: General Floating-Point" "22_ccc.htm")
    ("~$: Monetary Floating-Point" "22_ccd.htm")
    ("~A: Aesthetic" "22_cda.htm")
    ("~S: Standard" "22_cdb.htm")
    ("~W: Write" "22_cdc.htm")
    ("~_: Conditional Newline" "22_cea.htm")
    ("~<: Logical Block" "22_ceb.htm")
    ("~I: Indent" "22_cec.htm")
    ("~/: Call Function" "22_ced.htm")
    ("~T: Tabulate" "22_cfa.htm")
    ("~<: Justification" "22_cfb.htm")
    ("~>: End of Justification" "22_cfc.htm")
    ("~*: Go-To" "22_cga.htm")
    ("~[: Conditional Expression" "22_cgb.htm")
    ("~]: End of Conditional Expression" "22_cgc.htm")
    ("~{: Iteration" "22_cgd.htm")
    ("~}: End of Iteration" "22_cge.htm")
    ("~?: Recursive Processing" "22_cgf.htm")
    ("~(: Case Conversion" "22_cha.htm")
    ("~): End of Case Conversion" "22_chb.htm")
    ("~P: Plural" "22_chc.htm")
    ("~;: Clause Separator" "22_cia.htm")
    ("~^: Escape Upward" "22_cib.htm")
    ("~NEWLINE: Ignored Newline" "22_cic.htm")
    ("\(" "02_da.htm")
    (")" "02_db.htm")
    ("'" "02_dc.htm")
    (";" "02_dd.htm")
    ("\"" "02_de.htm")
    ("`" "02_df.htm")
    ("," "02_dg.htm")
    ("#" "02_dh.htm")
    ("#\\" "02_dha.htm")
    ("#'" "02_dhb.htm")
    ("#\(" "02_dhc.htm")
    ("#*" "02_dhd.htm")
    ("#:" "02_dhe.htm")
    ("#." "02_dhf.htm")
    ("#b" "02_dhg.htm")
    ("#o" "02_dhh.htm")
    ("#x" "02_dhi.htm")
    ("#r" "02_dhj.htm")
    ("#c" "02_dhk.htm")
    ("#a" "02_dhl.htm")
    ("#s" "02_dhm.htm")
    ("#p" "02_dhn.htm")
    ("#=" "02_dho.htm")
    ("##" "02_dhp.htm")
    ("#+" "02_dhq.htm")
    ("#-" "02_dhr.htm")
    ("#|" "02_dhs.htm")
    ("#<" "02_dht.htm")
    ("loop:with" "06_abb.htm")
    ("loop:for-as-..." "06_aba.htm")
    ("loop:for-as-arithmetic" "06_abaa.htm")
    ("loop:for-as-in-list" "06_abab.htm")
    ("loop:for-as-on-list" "06_abac.htm")
    ("loop:for-as-equals-then" "06_abad.htm")
    ("loop:for-as-across" "06_abae.htm")
    ("loop:for-as-hash" "06_abaf.htm")
    ("loop:for-as-package" "06_abag.htm")            
    ("loop:collect" "06_ac.htm")
    ("loop:append" "06_ac.htm")
    ("loop:nconc" "06_ac.htm")
    ("loop:count" "06_ac.htm")
    ("loop:maximize" "06_ac.htm")
    ("loop:minimize" "06_ac.htm")
    ("loop:sum" "06_ac.htm")
    ("loop:repeat" "06_ad.htm")
    ("loop:always" "06_ad.htm")
    ("loop:never" "06_ad.htm")
    ("loop:thereis" "06_ad.htm")
    ("loop:while" "06_ad.htm")
    ("loop:until" "06_ad.htm")
    ("loop:do" "06_ae.htm")
    ("loop:return" "06_ae.htm")
    ("loop:if" "06_af.htm")
    ("loop:when" "06_af.htm")
    ("loop:unless" "06_af.htm")
    ("loop:else" "06_af.htm")
    ("loop:it" "06_af.htm")
    ("loop:end" "06_af.htm")
    ("loop:named" "06_aga.htm")
    ("loop:initially" "06_agb.htm")
    ("loop:finally" "06_agb.htm")
    (":test" "17_ba.htm")
    (":test-not" "17_ba.htm")
    (":key" "17_bb.htm")
    (":eof-error-p" "23_aca.htm")
    (":recursive-p" "23_acb.htm"))
  "A couple of additions to the `standard' CLHS entries that can
be found in the symbol-index.")


(defparameter *mop-links*
  '(("add-dependent" "#add-dependent")
    ("add-direct-method" "#add-direct-method")
    ("add-direct-subclass" "#add-direct-subclass")
    ("add-method" "#add-method")
    ("allocate-instance" "#allocate-instance")
    ("class-... " "#class-")
    ("class-default-initargs" "#class-mo-readers")
    ("class-direct-default-initargs" "#class-mo-readers")
    ("class-direct-slots" "#class-mo-readers")
    ("class-direct-subclasses" "#class-mo-readers")
    ("class-direct-superclasses" "#class-mo-readers")
    ("class-finalized-p" "#class-mo-readers")
    ("class-name" "#class-mo-readers")
    ("class-precedence-list" "#class-mo-readers")
    ("class-prototype" "#class-mo-readers")
    ("class-slots" "#class-mo-readers")
    ("compute-applicable-methods" "#compute-applicable-methods")
    ("compute-applicable-methods-using-classes" "#compute-applicable-methods-using-classes")
    ("compute-class-precedence-list" "#compute-class-precedence-list")
    ("compute-default-initargs" "#compute-default-initargs")
    ("compute-discriminating-function" "#compute-discriminating-function")
    ("compute-effective-method" "#compute-effective-method")
    ("compute-effective-slot-definition" "#compute-effective-slot-definition")
    ("compute-slots" "#compute-slots")
    ("direct-slot-definition-class" "#direct-slot-definition-class")
    ("effective-slot-definition-class" "#effective-slot-definition-class")
    ("ensure-class" "#ensure-class")
    ("ensure-class-using-class" "#ensure-class-using-class")
    ("ensure-generic-function" "#ensure-generic-function")
    ("ensure-generic-function-using-class" "#ensure-generic-function-using-class")
    ("eql-specializer-object" "#eql-specializer-object")
    ("extract-lambda-list" "#extract-lambda-list")
    ("extract-specializer-names" "#extract-specializer-names")
    ("finalize-inheritance" "#finalize-inheritance")
    ("find-method-combination" "#find-method-combination")
    ("funcallable-standard-instance-access" "#funcallable-standard-instance-access")
    ("generic-function-..." "#generic-function-")
    ("generic-function-argument-precedence-order" "#gf-mo-readers")
    ("generic-function-declarations" "#gf-mo-readers")
    ("generic-function-lambda-list" "#gf-mo-readers")
    ("generic-function-method-class" "#gf-mo-readers")
    ("generic-function-method-combination" "#gf-mo-readers")
    ("generic-function-methods" "#gf-mo-readers")
    ("generic-function-name" "#gf-mo-readers")
    ("Initialization of Class Metaobjects" "#class-mo-init")
    ("Initialization of Generic Function Metaobjects" "#gf-mo-init")
    ("Initialization of Method Metaobjects" "#Initialization")
    ("Initialization of Slot Definition Metaobjects" "#Initialization")    
    ("intern-eql-specializer" "#intern-eql-specializer")
    ("make-instance" "#make-instance")
    ("make-method-lambda" "#make-method-lambda")
    ("map-dependents" "#map-dependents")
    ("method-..." "#method-")
    ("method-function" "#method-mo-readers")
    ("method-generic-function" "#method-mo-readers")
    ("method-lambda-list" "#method-mo-readers")
    ("method-specializers" "#method-mo-readers")
    ("method-qualifiers" "#method-mo-readers")
    ("accessor-method-slot-definition" "#method-mo-readers")
    ("Readers for Class Metaobjects" "#class-mo-readers")
    ("Readers for Generic Function Metaobjects" "#gf-mo-readers")
    ("Readers for Method Metaobjects" "#method-mo-readers")
    ("Readers for Slot Definition Metaobjects" "#slotd-mo-readers")
    ("reader-method-class" "#reader-method-class")
    ("remove-dependent" "#remove-dependent")
    ("remove-direct-method" "#remove-direct-method")
    ("remove-direct-subclass" "#remove-direct-subclass")
    ("remove-method" "#remove-method")
    ("set-funcallable-instance-function" "#set-funcallable-instance-function")
    ("\(setf class-name)" "#\(setf class-name)")
    ("\(setf generic-function-name)" "#\(setf generic-function-name)")
    ("\(setf slot-value-using-class)" "#\(setf slot-value-using-class)")
    ("slot-boundp-using-class" "#slot-boundp-using-class")
    ("slot-definition-..." "#slot-definition-")
    ("slot-definition-allocation" "#slotd-mo-readers")
    ("slot-definition-initargs" "#slotd-mo-readers")
    ("slot-definition-initform" "#slotd-mo-readers")
    ("slot-definition-initfunction" "#slotd-mo-readers")
    ("slot-definition-location" "#slotd-mo-readers")
    ("slot-definition-name" "#slotd-mo-readers")
    ("slot-definition-readers" "#slotd-mo-readers")
    ("slot-definition-writers" "#slotd-mo-readers")
    ("slot-definition-type" "#slotd-mo-readers")
    ("slot-makunbound-using-class" "#slot-makunbound-using-class")
    ("slot-value-using-class" "#slot-value-using-class")
    ("specializer-direct-generic-functions" "#specializer-direct-generic-functions")
    ("specializer-direct-methods" "#specializer-direct-methods")
    ("standard-instance-access" "#standard-instance-access")
    ("update-dependent" "#update-dependent")
    ("validate-superclass" "#validate-superclass")
    ("writer-method-class" "#writer-method-class"))
  "URL fragments for all relevant entries in the MOP dictionary
page.")