home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / clisp-li.000 / clisp-li / clisp-1996-07-22 / src / user2.lsp < prev   
Encoding:
Lisp/Scheme  |  1996-07-20  |  49.5 KB  |  1,201 lines
  1. ;;;; User-Interface, Teil 2
  2. ;;;; Funktionen fⁿrs Debugging (Kapitel 25.3)
  3. ;;;; Apropos, Describe, Dribble, Ed
  4. ;;;; 27.6.1992
  5.  
  6. (in-package "LISP")
  7. (export '(*editor* editor-name editor-tempfile edit-file uncompile saveinitmem))
  8. #+(or UNIX OS/2) (export '(run-shell-command run-program))
  9. (in-package "SYSTEM")
  10.  
  11. ;-------------------------------------------------------------------------------
  12. ;; APROPOS
  13.  
  14. (defun apropos-list (string &optional (package nil))
  15.   (let* ((L nil)
  16.          (fun #'(lambda (sym)
  17.                   (when
  18.                       #| (search string (symbol-name sym) :test #'char-equal) |#
  19.                       (sys::search-string-equal string sym) ; 15 mal schneller!
  20.                     (push sym L)
  21.                 ) )
  22.         ))
  23.     (if package
  24.       (system::map-symbols fun package)
  25.       (system::map-all-symbols fun)
  26.     )
  27.     (stable-sort (delete-duplicates L :test #'eq :from-end t)
  28.                  #'string< :key #'symbol-name
  29.     )
  30. ) )
  31.  
  32. (defun fbound-string (sym) ; liefert den Typ eines Symbols sym mit (fboundp sym)
  33.   (cond ((special-form-p sym)
  34.          (DEUTSCH "Spezialform"
  35.           ENGLISH "special form"
  36.           FRANCAIS "forme spΘciale")
  37.         )
  38.         ((functionp (symbol-function sym))
  39.          (DEUTSCH "Funktion"
  40.           ENGLISH "function"
  41.           FRANCAIS "fonction")
  42.         )
  43.         (t (DEUTSCH "Macro"
  44.             ENGLISH "macro"
  45.             FRANCAIS "macro")
  46. ) )     )
  47.  
  48. (defun apropos (string &optional (package nil))
  49.   (dolist (sym (apropos-list string package))
  50.     (print sym)
  51.     (when (fboundp sym)
  52.       (write-string "   ")
  53.       (write-string (fbound-string sym))
  54.     )
  55.     (when (boundp sym)
  56.       (write-string "   ")
  57.       (if (constantp sym)
  58.         (write-string (DEUTSCH "Konstante"
  59.                        ENGLISH "constant"
  60.                        FRANCAIS "constante")
  61.         )
  62.         (write-string (DEUTSCH "Variable"
  63.                        ENGLISH "variable"
  64.                        FRANCAIS "variable")
  65.     ) ) )
  66.     (when (or (get sym 'system::type-symbol)
  67.               (get sym 'system::defstruct-description)
  68.           )
  69.       (write-string "   ")
  70.       (write-string (DEUTSCH "Typ"
  71.                      ENGLISH "type"
  72.                      FRANCAIS "type")
  73.     ) )
  74.     (when (get sym 'clos::class)
  75.       (write-string "   ")
  76.       (write-string (DEUTSCH "Klasse"
  77.                      ENGLISH "class"
  78.                      FRANCAIS "classe")
  79.     ) )
  80.   )
  81.   (values)
  82. )
  83.  
  84. ;-------------------------------------------------------------------------------
  85. ;; DESCRIBE
  86.  
  87. (defun describe (obj &optional s &aux (more '()))
  88.   (cond ((eq s 'nil) (setq s *standard-output*))
  89.         ((eq s 't) (setq s *terminal-io*))
  90.   )
  91.   (format s (DEUTSCH "~%Beschreibung von~%"
  92.              ENGLISH "~%Description of~%"
  93.              FRANCAIS "~%Description de~%")
  94.   )
  95.   (format s "~A" (write-to-short-string obj sys::*prin-linelength*))
  96.   (format s (DEUTSCH "~%Das ist "
  97.              ENGLISH "~%This is "
  98.              FRANCAIS "~%Ceci est ")
  99.   )
  100.   (let ((type (type-of obj)))
  101.     ; Dispatch nach den m÷glichen Resultaten von TYPE-OF:
  102.     (if (atom type)
  103.       (case type
  104.         (CONS
  105.           (flet ((list-length (list)  ; vgl. CLTL, S. 265
  106.                    (do ((n 0 (+ n 2))
  107.                         (fast list (cddr fast))
  108.                         (slow list (cdr slow))
  109.                        )
  110.                        (nil)
  111.                      (when (atom fast) (return n))
  112.                      (when (atom (cdr fast)) (return (1+ n)))
  113.                      (when (eq (cdr fast) slow) (return nil))
  114.                 )) )
  115.             (let ((len (list-length obj)))
  116.               (if len
  117.                 (if (null (nthcdr len obj))
  118.                   (format s (DEUTSCH "eine Liste der LΣnge ~S."
  119.                              ENGLISH "a list of length ~S."
  120.                              FRANCAIS "une liste de longueur ~S.")
  121.                             len
  122.                   )
  123.                   (if (> len 1)
  124.                     (format s (DEUTSCH "eine punktierte Liste der LΣnge ~S."
  125.                                ENGLISH "a dotted list of length ~S."
  126.                                FRANCAIS "une liste pointΘe de longueur ~S.")
  127.                               len
  128.                     )
  129.                     (format s (DEUTSCH "ein Cons."
  130.                                ENGLISH "a cons."
  131.                                FRANCAIS "un ½cons╗.")
  132.                 ) ) )
  133.                 (format s (DEUTSCH "eine zyklische Liste."
  134.                            ENGLISH "a cyclic list."
  135.                            FRANCAIS "une liste circulaire.")
  136.         ) ) ) ) )
  137.         ((SYMBOL NULL)
  138.           (when (null obj)
  139.             (format s (DEUTSCH "die leere Liste, "
  140.                        ENGLISH "the empty list, "
  141.                        FRANCAIS "la liste vide, ")
  142.           ) )
  143.           (format s (DEUTSCH "das Symbol ~S"
  144.                      ENGLISH "the symbol ~S"
  145.                      FRANCAIS "le symbole ~S")
  146.                     obj
  147.           )
  148.           (when (keywordp obj)
  149.             (format s (DEUTSCH ", ein Keyword"
  150.                        ENGLISH ", a keyword"
  151.                        FRANCAIS ", un mot-clΘ")
  152.           ) )
  153.           (when (boundp obj)
  154.             (if (constantp obj)
  155.               (format s (DEUTSCH ", eine Konstante"
  156.                          ENGLISH ", a constant"
  157.                          FRANCAIS ", une constante")
  158.               )
  159.               (if (sys::special-variable-p obj)
  160.                 (format s (DEUTSCH ", eine SPECIAL-deklarierte Variable"
  161.                            ENGLISH ", a variable declared SPECIAL"
  162.                            FRANCAIS ", une variable declarΘe SPECIAL")
  163.                 )
  164.                 (format s (DEUTSCH ", eine Variable"
  165.                            ENGLISH ", a variable"
  166.                            FRANCAIS ", une variable")
  167.             ) ) )
  168.             (when (symbol-macro-expand obj)
  169.               (format s (DEUTSCH " (Macro)"
  170.                          ENGLISH " (macro)"
  171.                          FRANCAIS " (macro)")
  172.               )
  173.               (push `(MACROEXPAND-1 ',obj) more)
  174.             )
  175.             (push `,obj more)
  176.             (push `(SYMBOL-VALUE ',obj) more)
  177.           )
  178.           (when (fboundp obj)
  179.             (format s (DEUTSCH ", benennt "
  180.                        ENGLISH ", names "
  181.                        FRANCAIS ", le nom ")
  182.             )
  183.             (cond ((special-form-p obj)
  184.                    (format s (DEUTSCH "eine Special-Form"
  185.                               ENGLISH "a special form"
  186.                               FRANCAIS "d'une forme spΘciale")
  187.                    )
  188.                    (when (macro-function obj)
  189.                      (format s (DEUTSCH " mit Macro-Definition"
  190.                                 ENGLISH " with macro definition"
  191.                                 FRANCAIS ", aussi d'un macro")
  192.                   )) )
  193.                   ((functionp (symbol-function obj))
  194.                    (format s (DEUTSCH "eine Funktion"
  195.                               ENGLISH "a function"
  196.                               FRANCAIS "d'une fonction")
  197.                    )
  198.                    (push `#',obj more)
  199.                    (push `(SYMBOL-FUNCTION ',obj) more)
  200.                   )
  201.                   (t ; (macro-function obj)
  202.                    (format s (DEUTSCH "einen Macro"
  203.                               ENGLISH "a macro"
  204.                               FRANCAIS "d'un macro")
  205.                   ))
  206.           ) )
  207.           (when (or (get obj 'system::type-symbol)
  208.                     (get obj 'system::defstruct-description)
  209.                 )
  210.             (format s (DEUTSCH ", benennt einen Typ"
  211.                        ENGLISH ", names a type"
  212.                        FRANCAIS ", le nom d'un type")
  213.           ) )
  214.           (when (get obj 'clos::class)
  215.             (format s (DEUTSCH ", benennt eine Klasse"
  216.                        ENGLISH ", names a class"
  217.                        FRANCAIS ", le nom d'une classe")
  218.           ) )
  219.           (when (symbol-plist obj)
  220.             (let ((properties
  221.                     (do ((l nil)
  222.                          (pl (symbol-plist obj) (cddr pl)))
  223.                         ((null pl) (nreverse l))
  224.                       (push (car pl) l)
  225.                  )) )
  226.               (format s (DEUTSCH ", hat die Propert~@P ~{~S~^, ~}"
  227.                          ENGLISH ", has the propert~@P ~{~S~^, ~}"
  228.                          FRANCAIS ", a ~[~;la propriΘtΘ~:;les propriΘtΘs~] ~{~S~^, ~}")
  229.                         (length properties) properties
  230.             ) )
  231.             (push `(SYMBOL-PLIST ',obj) more)
  232.           )
  233.           (format s (DEUTSCH "."
  234.                      ENGLISH "."
  235.                      FRANCAIS ".")
  236.           )
  237.           (format s (DEUTSCH "~%Das Symbol "
  238.                      ENGLISH "~%The symbol "
  239.                      FRANCAIS "~%Le symbole ")
  240.           )
  241.           (let ((home (symbol-package obj)))
  242.             (if home
  243.               (format s (DEUTSCH "liegt in ~S"
  244.                          ENGLISH "lies in ~S"
  245.                          FRANCAIS "est situΘ dans ~S")
  246.                         home
  247.               )
  248.               (format s (DEUTSCH "ist uninterniert"
  249.                          ENGLISH "is uninterned"
  250.                          FRANCAIS "n'appartient α aucun paquetage")
  251.             ) )
  252.             (let ((accessible-packs nil))
  253.               (let ((*print-escape* t)
  254.                     (*print-readably* nil))
  255.                 (let ((normal-printout ; externe ReprΣsentation ohne Package-Marker
  256.                         (if home
  257.                           (let ((*package* home)) (prin1-to-string obj))
  258.                           (let ((*print-gensym* nil)) (prin1-to-string obj))
  259.                      )) )
  260.                   (dolist (pack (list-all-packages))
  261.                     (when ; obj in pack accessible?
  262.                           (string=
  263.                             (let ((*package* pack)) (prin1-to-string obj))
  264.                             normal-printout
  265.                           )
  266.                       (push pack accessible-packs)
  267.               ) ) ) )
  268.               (when accessible-packs
  269.                 (format s (DEUTSCH " und ist in ~:[der Package~;den Packages~] ~{~A~^, ~} accessible"
  270.                            ENGLISH " and is accessible in the package~:[~;s~] ~{~A~^, ~}"
  271.                            FRANCAIS " et est visible dans le~:[ paquetage~;s paquetages~] ~{~A~^, ~}")
  272.                           (cdr accessible-packs)
  273.                           (sort (mapcar #'package-name accessible-packs) #'string<)
  274.           ) ) ) )
  275.           (format s (DEUTSCH "."
  276.                      ENGLISH "."
  277.                      FRANCAIS ".")
  278.         ) )
  279.         ((FIXNUM BIGNUM)
  280.           (format s (DEUTSCH "eine ganze Zahl, belegt ~S Bits, ist als ~:(~A~) reprΣsentiert."
  281.                      ENGLISH "an integer, uses ~S bits, is represented as a ~(~A~)."
  282.                      FRANCAIS "un nombre entier, occupant ~S bits, est reprΘsentΘ comme ~(~A~).")
  283.                     (integer-length obj) type
  284.         ) )
  285.         (RATIO
  286.           (format s (DEUTSCH "eine rationale, nicht ganze Zahl."
  287.                      ENGLISH "a rational, not integral number."
  288.                      FRANCAIS "un nombre rationnel mais pas entier.")
  289.         ) )
  290.         ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
  291.           (format s (DEUTSCH "eine Flie▀kommazahl mit ~S Mantissenbits (~:(~A~))."
  292.                      ENGLISH "a float with ~S bits of mantissa (~(~A~))."
  293.                      FRANCAIS "un nombre α virgule flottante avec une prΘcision de ~S bits (un ~(~A~)).")
  294.                     (float-digits obj) type
  295.         ) )
  296.         (COMPLEX
  297.           (format s (DEUTSCH "eine komplexe Zahl "
  298.                      ENGLISH "a complex number "
  299.                      FRANCAIS "un nombre complexe ")
  300.           )
  301.           (let ((x (realpart obj))
  302.                 (y (imagpart obj)))
  303.             (if (zerop y)
  304.               (if (zerop x)
  305.                 (format s (DEUTSCH "im Ursprung"
  306.                            ENGLISH "at the origin"
  307.                            FRANCAIS "α l'origine")
  308.                 )
  309.                 (format s (DEUTSCH "auf der ~:[posi~;nega~]tiven reellen Achse"
  310.                            ENGLISH "on the ~:[posi~;nega~]tive real axis"
  311.                            FRANCAIS "sur la partie ~:[posi~;nega~]tive de l'axe rΘelle")
  312.                           (minusp x)
  313.               ) )
  314.               (if (zerop x)
  315.                 (format s (DEUTSCH "auf der ~:[posi~;nega~]tiven imaginΣren Achse"
  316.                            ENGLISH "on the ~:[posi~;nega~]tive imaginary axis"
  317.                            FRANCAIS "sur la partie ~:[posi~;nega~]tive de l'axe imaginaire")
  318.                           (minusp y)
  319.                 )
  320.                 (format s (DEUTSCH "im ~:[~:[ers~;vier~]~;~:[zwei~;drit~]~]ten Quadranten"
  321.                            ENGLISH "in ~:[~:[first~;fourth~]~;~:[second~;third~]~] the quadrant"
  322.                            FRANCAIS "dans le ~:[~:[premier~;quatriΦme~]~;~:[deuxiΦme~;troisiΦme~]~] quartier")
  323.                           (minusp x) (minusp y)
  324.           ) ) ) )
  325.           (format s (DEUTSCH " der Gau▀schen Zahlenebene."
  326.                      ENGLISH " of the Gaussian number plane."
  327.                      FRANCAIS " du plan Gaussien.")
  328.         ) )
  329.         (CHARACTER
  330.           (format s (DEUTSCH "ein Zeichen"
  331.                      ENGLISH "a character"
  332.                      FRANCAIS "un caractΦre")
  333.           )
  334.           (unless (zerop (char-bits obj))
  335.             (format s (DEUTSCH " mit Zusatzbits"
  336.                        ENGLISH " with additional bits"
  337.                        FRANCAIS " avec des bits supplΘmentaires")
  338.           ) )
  339.           (unless (zerop (char-font obj))
  340.             (format s (DEUTSCH " aus Zeichensatz ~S"
  341.                        ENGLISH " from font ~S"
  342.                        FRANCAIS " de la police (½font╗) ~S")
  343.                       (char-font obj)
  344.           ) )
  345.           (format s (DEUTSCH "."
  346.                      ENGLISH "."
  347.                      FRANCAIS ".")
  348.           )
  349.           (format s (DEUTSCH "~%Es ist ein ~:[nicht ~;~]druckbares Zeichen."
  350.                      ENGLISH "~%It is a ~:[non-~;~]printable character."
  351.                      FRANCAIS "~%C'est un caractΦre ~:[non ~;~]imprimable.")
  352.                     (graphic-char-p obj)
  353.           )
  354.           (unless (standard-char-p obj)
  355.             (format s (DEUTSCH "~%Seine Verwendung ist nicht portabel."
  356.                        ENGLISH "~%Its use is non-portable."
  357.                        FRANCAIS "~%Il n'est pas portable de l'utiliser.")
  358.           ) )
  359.         )
  360.         (FUNCTION ; (SYS::CLOSUREP obj) ist erfⁿllt
  361.           (let ((compiledp (compiled-function-p obj)))
  362.             (format s (DEUTSCH "eine ~:[interpret~;compil~]ierte Funktion."
  363.                        ENGLISH "a~:[n interpret~; compil~]ed function."
  364.                        FRANCAIS "une fonction ~:[interprΘt~;compil~]Θe.")
  365.                       compiledp
  366.             )
  367.             (if compiledp
  368.               (multiple-value-bind (req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p)
  369.                   (sys::signature obj)
  370.                 (describe-signature s req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p)
  371.                 (push `(DISASSEMBLE #',(sys::closure-name obj)) more)
  372.                 (push `(DISASSEMBLE ',obj) more)
  373.               )
  374.               (progn
  375.                 (format s (DEUTSCH "~%Argumentliste: ~S"
  376.                            ENGLISH "~%argument list: ~S"
  377.                            FRANCAIS "~%Liste des arguments: ~S")
  378.                           (car (sys::%record-ref obj 1))
  379.                 )
  380.                 (let ((doc (sys::%record-ref obj 2)))
  381.                   (when doc
  382.                     (format s (DEUTSCH "~%Dokumentation: ~A"
  383.                                ENGLISH "~%documentation: ~A"
  384.                                FRANCAIS "~%Documentation: ~A")
  385.                               doc
  386.               ) ) ) )
  387.         ) ) )
  388.         (COMPILED-FUNCTION ; nur SUBRs und FSUBRs
  389.           (if (functionp obj)
  390.             ; SUBR
  391.             (progn
  392.               (format s (DEUTSCH "eine eingebaute System-Funktion."
  393.                          ENGLISH "a built-in system function."
  394.                          FRANCAIS "une fonction prΘdΘfinie du systΦme.")
  395.               )
  396.               (multiple-value-bind (name req-anz opt-anz rest-p keywords allow-other-keys)
  397.                   (sys::subr-info obj)
  398.                 (when name
  399.                   (describe-signature s req-anz opt-anz rest-p keywords keywords allow-other-keys)
  400.             ) ) )
  401.             ; FSUBR
  402.             (format s (DEUTSCH "ein Special-Form-Handler."
  403.                        ENGLISH "a special form handler."
  404.                        FRANCAIS "un interprΘteur de forme spΘciale.")
  405.         ) ) )
  406.         #+FFI
  407.         (FOREIGN-ADDRESS
  408.           (format s (DEUTSCH "eine Foreign-Adresse."
  409.                      ENGLISH "a foreign address"
  410.                      FRANCAIS "une addresse ΘtrangΦre.")
  411.         ) )
  412.         #+FFI
  413.         (FOREIGN-VARIABLE
  414.           (format s (DEUTSCH "eine Foreign-Variable vom Foreign-Typ ~S."
  415.                      ENGLISH "a foreign variable of foreign type ~S."
  416.                      FRANCAIS "une variable ΘtrangΦre de type Θtranger ~S.")
  417.                     (deparse-c-type (sys::%record-ref obj 3))
  418.         ) )
  419.         #+FFI
  420.         (FOREIGN-FUNCTION
  421.           (format s (DEUTSCH "eine Foreign-Funktion."
  422.                      ENGLISH "a foreign function."
  423.                      FRANCAIS "une fonction ΘtrangΦre.")
  424.         ) )
  425.         ((STREAM FILE-STREAM SYNONYM-STREAM BROADCAST-STREAM
  426.           CONCATENATED-STREAM TWO-WAY-STREAM ECHO-STREAM STRING-STREAM
  427.          )
  428.           (format s (DEUTSCH "ein ~:[~:[geschlossener ~;Output-~]~;~:[Input-~;bidirektionaler ~]~]Stream."
  429.                      ENGLISH "a~:[~:[ closed ~;n output-~]~;~:[n input-~;n input/output-~]~]stream."
  430.                      FRANCAIS "un ½stream╗ ~:[~:[fermΘ~;de sortie~]~;~:[d'entrΘe~;d'entrΘe/sortie~]~].")
  431.                     (input-stream-p obj) (output-stream-p obj)
  432.         ) )
  433.         (PACKAGE
  434.           (if (package-name obj)
  435.             (progn
  436.               (format s (DEUTSCH "die Package mit Namen ~A"
  437.                          ENGLISH "the package named ~A"
  438.                          FRANCAIS "le paquetage de nom ~A")
  439.                         (package-name obj)
  440.               )
  441.               (let ((nicknames (package-nicknames obj)))
  442.                 (when nicknames
  443.                   (format s (DEUTSCH " und zusΣtzlichen Namen ~{~A~^, ~}"
  444.                              ENGLISH ". It has the nicknames ~{~A~^, ~}"
  445.                              FRANCAIS ". Il porte aussi les noms ~{~A~^, ~}")
  446.                             nicknames
  447.               ) ) )
  448.               (format s (DEUTSCH "."
  449.                          ENGLISH "."
  450.                          FRANCAIS ".")
  451.               )
  452.               (let ((use-list (package-use-list obj))
  453.                     (used-by-list (package-used-by-list obj)))
  454.                 (format s (DEUTSCH "~%Sie "
  455.                            ENGLISH "~%It "
  456.                            FRANCAIS "~%Il ")
  457.                 )
  458.                 (when use-list
  459.                   (format s (DEUTSCH "importiert die externen Symbole der Package~:[~;s~] ~{~A~^, ~} und "
  460.                              ENGLISH "imports the external symbols of the package~:[~;s~] ~{~A~^, ~} and "
  461.                              FRANCAIS "importe les symboles externes d~:[u paquetage~;es paquetages~] ~{~A~^, ~} et ")
  462.                             (cdr use-list) (mapcar #'package-name use-list)
  463.                 ) )
  464.                 (format s (DEUTSCH "exportiert ~:[keine Symbole~;die Symbole~:*~{~<~%~:; ~S~>~^~}~]"
  465.                            ENGLISH "exports ~:[no symbols~;the symbols~:*~{~<~%~:; ~S~>~^~}~]"
  466.                            FRANCAIS "~:[n'exporte pas de symboles~;exporte les symboles~:*~{~<~%~:; ~S~>~^~}~]")
  467.                           ; Liste aller exportierten Symbole:
  468.                           (let ((L nil))
  469.                             (do-external-symbols (s obj) (push s L))
  470.                             (sort L #'string< :key #'symbol-name)
  471.                 )         )
  472.                 (when used-by-list
  473.                   (format s (DEUTSCH " an die Package~:[~;s~] ~{~A~^, ~}"
  474.                              ENGLISH " to the package~:[~;s~] ~{~A~^, ~}"
  475.                              FRANCAIS " vers le~:[ paquetage~;s paquetages~] ~{~A~^, ~}")
  476.                             (cdr used-by-list) (mapcar #'package-name used-by-list)
  477.                 ) )
  478.                 (format s (DEUTSCH "."
  479.                            ENGLISH "."
  480.                            FRANCAIS ".")
  481.             ) ) )
  482.             (format s (DEUTSCH "eine gel÷schte Package."
  483.                        ENGLISH "a deleted package."
  484.                        FRANCAIS "un paquetage ΘliminΘ.")
  485.         ) ) )
  486.         (HASH-TABLE
  487.           (format s (DEUTSCH "eine Hash-Tabelle mit ~S Eintr~:*~[Σgen~;ag~:;Σgen~]."
  488.                      ENGLISH "a hash table with ~S entr~:@P."
  489.                      FRANCAIS "un tableau de hachage avec ~S entrΘe~:*~[s~;~:;s~].")
  490.                     (hash-table-count obj)
  491.         ) )
  492.         (READTABLE
  493.           (format s (DEUTSCH "~:[eine ~;die Common-Lisp-~]Readtable."
  494.                      ENGLISH "~:[a~;the Common Lisp~] readtable."
  495.                      FRANCAIS "~:[un~;le~] tableau de lecture~:*~:[~; de Common Lisp~].")
  496.                     (equalp obj (copy-readtable))
  497.         ) )
  498.         ((PATHNAME #+LOGICAL-PATHNAMES LOGICAL-PATHNAME)
  499.           (format s (DEUTSCH "ein ~:[~;portabler ~]Pathname~:[.~;~:*, aufgebaut aus:~{~A~}~]"
  500.                      ENGLISH "a ~:[~;portable ~]pathname~:[.~;~:*, with the following components:~{~A~}~]"
  501.                      FRANCAIS "un ½pathname╗~:[~; portable~]~:[.~;~:*, composΘ de:~{~A~}~]")
  502.                     (sys::logical-pathname-p obj)
  503.                     (mapcan #'(lambda (kw component)
  504.                                 (when component
  505.                                   (list (format nil "~%~A = ~A"
  506.                                                     (symbol-name kw)
  507.                                                     (make-pathname kw component)
  508.                               ) ) )     )
  509.                       '(:host :device :directory :name :type :version)
  510.                       (list
  511.                         (pathname-host obj)
  512.                         (pathname-device obj)
  513.                         (pathname-directory obj)
  514.                         (pathname-name obj)
  515.                         (pathname-type obj)
  516.                         (pathname-version obj)
  517.         ) )         ) )
  518.         (RANDOM-STATE
  519.           (format s (DEUTSCH "ein Random-State."
  520.                      ENGLISH "a random-state."
  521.                      FRANCAIS "un ½random-state╗.")
  522.         ) )
  523.         (BYTE
  524.           (format s (DEUTSCH "ein Byte-Specifier, bezeichnet die ~S Bits ab Bitposition ~S eines Integers."
  525.                      ENGLISH "a byte specifier, denoting the ~S bits starting at bit position ~S of an integer."
  526.                      FRANCAIS "un intervalle de bits, comportant ~S bits α partir de la position ~S d'un entier.")
  527.                     (byte-size obj) (byte-position obj)
  528.         ) )
  529.         (LOAD-TIME-EVAL
  530.           (format s (DEUTSCH "eine Absicht der Evaluierung zur Ladezeit." ; ??
  531.                      ENGLISH "a load-time evaluation promise." ; ??
  532.                      FRANCAIS "une promesse d'Θvaluation au moment du chargement.") ; ??
  533.         ) )
  534.         (READ-LABEL
  535.           (format s (DEUTSCH "eine Markierung zur Aufl÷sung von #~D#-Verweisen bei READ."
  536.                      ENGLISH "a label used for resolving #~D# references during READ."
  537.                      FRANCAIS "une marque destinΘe α rΘsoudre #~D# au cours de READ.")
  538.                     (logand (sys::address-of obj) '#,(ash most-positive-fixnum -1))
  539.         ) )
  540.         (FRAME-POINTER
  541.           (format s (DEUTSCH "ein Pointer in den Stack. Er zeigt auf:"
  542.                      ENGLISH "a pointer into the stack. It points to:"
  543.                      FRANCAIS "un pointeur dans la pile. Il pointe vers :")
  544.           )
  545.           (sys::describe-frame s obj)
  546.         )
  547.         (SYSTEM-INTERNAL
  548.           (format s (DEUTSCH "ein Objekt mit besonderen Eigenschaften."
  549.                      ENGLISH "a special-purpose object."
  550.                      FRANCAIS "un objet distinguΘ.")
  551.         ) )
  552.         (ADDRESS
  553.           (format s (DEUTSCH "eine Maschinen-Adresse."
  554.                      ENGLISH "a machine address."
  555.                      FRANCAIS "une addresse au niveau de la machine.")
  556.         ) )
  557.         (t
  558.          (if (and (symbolp type) (sys::%structure-type-p type obj))
  559.            ; Structure
  560.            (progn
  561.              (format s (DEUTSCH "eine Structure vom Typ ~S."
  562.                         ENGLISH "a structure of type ~S."
  563.                         FRANCAIS "une structure de type ~S.")
  564.                        type
  565.              )
  566.              (let ((type (sys::%record-ref obj 0)))
  567.                (when (cdr type)
  568.                  (format s (DEUTSCH "~%Als solche ist sie auch eine Structure vom Typ ~{~S~^, ~}."
  569.                             ENGLISH "~%As such, it is also a structure of type ~{~S~^, ~}."
  570.                             FRANCAIS "~%En tant que telle, c'est aussi une structure de type ~{~S~^, ~}.")
  571.                            (cdr type)
  572.            ) ) ) )
  573.            ; CLOS-Instanz
  574.            (progn
  575.              (format s (DEUTSCH "eine Instanz der CLOS-Klasse ~S."
  576.                         ENGLISH "an instance of the CLOS class ~S."
  577.                         FRANCAIS "un objet appartenant α la classe ~S de CLOS.")
  578.                        (clos:class-of obj)
  579.              )
  580.              (clos:describe-object obj s)
  581.          ) )
  582.       ) )
  583.       ; Array-Typen
  584.       (let ((rank (array-rank obj))
  585.             (eltype (array-element-type obj)))
  586.         (format s (DEUTSCH "ein~:[~; einfacher~] ~A-dimensionaler Array"
  587.                    ENGLISH "a~:[~; simple~] ~A dimensional array"
  588.                    FRANCAIS "une matrice~:[~; simple~] α ~A dimension~:P")
  589.                   (simple-array-p obj) rank
  590.         )
  591.         (when (eql rank 1)
  592.           (format s (DEUTSCH " (Vektor)"
  593.                      ENGLISH " (vector)"
  594.                      FRANCAIS " (vecteur)")
  595.         ) )
  596.         (unless (eq eltype 'T)
  597.           (format s (DEUTSCH " von ~:(~A~)s"
  598.                      ENGLISH " of ~(~A~)s"
  599.                      FRANCAIS " de ~(~A~)s")
  600.                     eltype
  601.         ) )
  602.         (when (adjustable-array-p obj)
  603.           (format s (DEUTSCH ", adjustierbar"
  604.                      ENGLISH ", adjustable"
  605.                      FRANCAIS ", ajustable")
  606.         ) )
  607.         (when (plusp rank)
  608.           (format s (DEUTSCH ", der Gr÷▀e ~{~S~^ x ~}"
  609.                      ENGLISH ", of size ~{~S~^ x ~}"
  610.                      FRANCAIS ", de grandeur ~{~S~^ x ~}")
  611.                     (array-dimensions obj)
  612.           )
  613.           (when (array-has-fill-pointer-p obj)
  614.             (format s (DEUTSCH " und der momentanen LΣnge (Fill-Pointer) ~S"
  615.                        ENGLISH " and current length (fill-pointer) ~S"
  616.                        FRANCAIS " et longueur courante (fill-pointer) ~S")
  617.                       (fill-pointer obj)
  618.         ) ) )
  619.         (format s (DEUTSCH "."
  620.                    ENGLISH "."
  621.                    FRANCAIS ".")
  622.       ) )
  623.   ) )
  624.   (when more
  625.     (format s (DEUTSCH "~%Mehr Information durch Auswerten von ~{~S~^ oder ~}."
  626.                ENGLISH "~%For more information, evaluate ~{~S~^ or ~}."
  627.                FRANCAIS "~%Pour obtenir davantage d'information, Θvaluez ~{~S~^ ou ~}.")
  628.               (nreverse more)
  629.   ) )
  630.   (values)
  631. )
  632.  
  633. ; Liefert die Signatur eines funktionalen Objekts, als Werte:
  634. ; 1. req-anz
  635. ; 2. opt-anz
  636. ; 3. rest-p
  637. ; 4. key-p
  638. ; 5. keyword-list
  639. ; 6. allow-other-keys-p
  640. (defun function-signature (obj)
  641.   (if (sys::closurep obj)
  642.     (if (compiled-function-p obj)
  643.       ; compilierte Closure
  644.       (multiple-value-bind (req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p)
  645.           (sys::signature obj) ; siehe compiler.lsp
  646.         (values req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p)
  647.       )
  648.       ; interpretierte Closure
  649.       (let ((clos_keywords (sys::%record-ref obj 16)))
  650.         (values (sys::%record-ref obj 12) ; req_anz
  651.                 (sys::%record-ref obj 13) ; opt_anz
  652.                 (sys::%record-ref obj 19) ; rest_flag
  653.                 (not (numberp clos_keywords))
  654.                 (if (not (numberp clos_keywords)) (copy-list clos_keywords))
  655.                 (sys::%record-ref obj 18) ; allow_flag
  656.       ) )
  657.     )
  658.     (cond #+FFI
  659.           ((eq (type-of obj) 'FOREIGN-FUNCTION)
  660.            (values (sys::foreign-function-signature obj) 0 nil nil nil nil)
  661.           )
  662.           (t
  663.            (multiple-value-bind (name req-anz opt-anz rest-p keywords allow-other-keys)
  664.                (sys::subr-info obj)
  665.              (if name
  666.                (values req-anz opt-anz rest-p keywords keywords allow-other-keys)
  667.                (error (DEUTSCH "~S: ~S ist keine Funktion."
  668.                        ENGLISH "~S: ~S is not a function."
  669.                        FRANCAIS "~S : ~S n'est pas une fonction.")
  670.                       'function-signature obj
  671.                )
  672. ) ) )     )) )
  673.  
  674. (defun describe-signature (s req-anz opt-anz rest-p keyword-p keywords allow-other-keys)
  675.   (format s (DEUTSCH "~%Argumentliste: "
  676.              ENGLISH "~%argument list: "
  677.              FRANCAIS "~%Liste des arguments : ")
  678.   )
  679.   (format s "(~{~A~^ ~})"
  680.     (let ((args '()) (count 0))
  681.       (dotimes (i req-anz)
  682.         (incf count)
  683.         (push (format nil "ARG~D" count) args)
  684.       )
  685.       (when (plusp opt-anz)
  686.         (push '&OPTIONAL args)
  687.         (dotimes (i opt-anz)
  688.           (incf count)
  689.           (push (format nil "ARG~D" count) args)
  690.       ) )
  691.       (when rest-p
  692.         (push '&REST args)
  693.         (push "OTHER-ARGS" args)
  694.       )
  695.       (when keyword-p
  696.         (push '&KEY args)
  697.         (dolist (kw keywords) (push (prin1-to-string kw) args))
  698.         (when allow-other-keys (push '&ALLOW-OTHER-KEYS args))
  699.       )
  700.       (nreverse args)
  701. ) ) )
  702. ;; DOCUMENTATION mit abfragen und ausgeben??
  703. ;; function, variable, type, structure, setf
  704.  
  705. ; Gibt object in einen String aus, der nach M÷glichkeit h÷chstens max Zeichen
  706. ; lang sein soll.
  707. (defun write-to-short-string (object max)
  708.   ; Methode: probiere
  709.   ; level = 0: length = 0,1,2
  710.   ; level = 1: length = 1,2,3,4
  711.   ; level = 2: length = 2,...,6
  712.   ; usw. bis maximal level = 16.
  713.   ; Dabei level m÷glichst gro▀, und bei festem level length m÷glichst gro▀.
  714.   (if (or (numberp object) (symbolp object)) ; von length und level unbeeinflu▀t?
  715.     (write-to-string object)
  716.     (macrolet ((minlength (level) `,level)
  717.                (maxlength (level) `(* 2 (+ ,level 1))))
  718.       ; Um level m÷glist gro▀ zu bekommen, dabei length = minlength wΣhlen.
  719.       (let* ((level ; BinΣrsuche nach dem richtigen level
  720.                (let ((level1 0) (level2 16))
  721.                  (loop
  722.                    (when (= (- level2 level1) 1) (return))
  723.                    (let ((levelm (floor (+ level1 level2) 2)))
  724.                      (if (<= (length (write-to-string object :level levelm :length (minlength levelm))) max)
  725.                        (setq level1 levelm) ; levelm pa▀t, probiere gr÷▀ere
  726.                        (setq level2 levelm) ; levelm pa▀t nicht, probiere kleinere
  727.                  ) ) )
  728.                  level1
  729.              ) )
  730.              (length ; BinΣrsuche nach dem richtigen length
  731.                (let ((length1 (minlength level)) (length2 (maxlength level)))
  732.                  (loop
  733.                    (when (= (- length2 length1) 1) (return))
  734.                    (let ((lengthm (floor (+ length1 length2) 2)))
  735.                      (if (<= (length (write-to-string object :level level :length lengthm)) max)
  736.                        (setq length1 lengthm) ; lengthm pa▀t, probiere gr÷▀ere
  737.                        (setq length2 lengthm) ; lengthm pa▀t nicht, probiere kleinere
  738.                  ) ) )
  739.                  length1
  740.             )) )
  741.         (write-to-string object :level level :length length)
  742. ) ) ) )
  743.  
  744. ;-------------------------------------------------------------------------------
  745. ;; DRIBBLE
  746.  
  747. (let ((dribble-file nil) (dribbled-input nil) (dribbled-output nil)
  748.       (dribbled-error-output nil) (dribbled-trace-output nil)
  749.       (dribbled-query-io nil) (dribbled-debug-io nil))
  750.   (defun dribble (&optional file)
  751.     (if file
  752.       (progn
  753.         (if dribble-file
  754.           (warn (DEUTSCH "Es wird bereits auf ~S protokolliert."
  755.                  ENGLISH "Already dribbling to ~S"
  756.                  FRANCAIS "Le protocole est dΘjα Θcrit sur ~S.")
  757.                 dribble-file
  758.           )
  759.           (flet ((goes-to-terminal (stream) ; this is a hack
  760.                    (and (typep stream 'synonym-stream)
  761.                         (eq (synonym-stream-symbol stream) '*terminal-io*)
  762.                 )) )
  763.             (setq dribble-file (open file :direction :output)
  764.                   dribbled-input *standard-input*
  765.                   dribbled-output *standard-output*
  766.                   dribbled-error-output nil
  767.                   dribbled-trace-output nil
  768.                   dribbled-query-io nil
  769.                   dribbled-debug-io nil
  770.             )
  771.             (setq *standard-input* (make-echo-stream *standard-input* dribble-file))
  772.             (setq *standard-output* (make-broadcast-stream *standard-output* dribble-file))
  773.             (when (goes-to-terminal *error-output*)
  774.               (setq dribbled-error-output *error-output*)
  775.               (setq *error-output* (make-broadcast-stream *error-output* dribble-file))
  776.             )
  777.             (when (goes-to-terminal *trace-output*)
  778.               (setq dribbled-trace-output *trace-output*)
  779.               (setq *trace-output* (make-broadcast-stream *trace-output* dribble-file))
  780.             )
  781.             (when (goes-to-terminal *query-io*)
  782.               (setq dribbled-query-io *query-io*)
  783.               (setq *query-io*
  784.                     (make-two-way-stream
  785.                           (make-echo-stream *query-io* dribble-file)
  786.                           (make-broadcast-stream *query-io* dribble-file)
  787.             ) )     )
  788.             (when (goes-to-terminal *debug-io*)
  789.               (setq dribbled-debug-io *debug-io*)
  790.               (setq *debug-io*
  791.                     (make-two-way-stream
  792.                           (make-echo-stream *debug-io* dribble-file)
  793.                           (make-broadcast-stream *debug-io* dribble-file)
  794.             ) )     )
  795.         ) )
  796.         dribble-file
  797.       )
  798.       (if dribble-file
  799.         (progn
  800.           (setq *standard-input* dribbled-input)
  801.           (setq *standard-output* dribbled-output)
  802.           (when dribbled-error-output (setq *error-output* dribbled-error-output))
  803.           (when dribbled-trace-output (setq *trace-output* dribbled-trace-output))
  804.           (when dribbled-query-io (setq *query-io* dribbled-query-io))
  805.           (when dribbled-debug-io (setq *query-io* dribbled-debug-io))
  806.           (setq dribbled-input nil)
  807.           (setq dribbled-output nil)
  808.           (setq dribbled-error-output nil)
  809.           (setq dribbled-trace-output nil)
  810.           (setq dribbled-query-io nil)
  811.           (setq dribbled-debug-io nil)
  812.           (prog1
  813.             dribble-file
  814.             (close dribble-file)
  815.             (setq dribble-file nil)
  816.         ) )
  817.         (warn (DEUTSCH "Es wird zur Zeit nicht protokolliert."
  818.                ENGLISH "Currently not dribbling."
  819.                FRANCAIS "Aucun protocole n'est couramment Θcrit.")
  820. ) ) ) ) )
  821.  
  822. ;-------------------------------------------------------------------------------
  823. ;; ED
  824.  
  825. ;; *editor*, editor-name und editor-tempfile sind in CONFIG.LSP definiert.
  826. ;; Hier stehen nur die Defaults.
  827.  
  828. ;; Der Name des Editors:
  829. (defparameter *editor* nil)
  830.  
  831. ;; Liefert den Namen des Editors:
  832. (defun editor-name () *editor*)
  833.  
  834. ;; Das temporΣre File, das LISP beim Editieren anlegt:
  835. (defun editor-tempfile ()
  836.   #+DOS "LISPTEMP.LSP"
  837.   #+OS/2 "lisptemp.lsp"
  838.   #+AMIGA "T:lisptemp.lsp"
  839.   #+UNIX (merge-pathnames "lisptemp.lsp" (user-homedir-pathname))
  840. )
  841.  
  842. ;; (edit-file file) editiert ein File.
  843. (defun edit-file (file)
  844.   (unless (editor-name)
  845.     (error-of-type 'error
  846.       (DEUTSCH "Kein externer Editor installiert."
  847.        ENGLISH "No external editor installed."
  848.        FRANCAIS "Un Θditeur externe n'est pas installΘ.")
  849.   ) )
  850.   ; Damit TRUENAME keinen Fehler liefert, wenn das File noch nicht existiert,
  851.   ; stellen wir sicher, da▀ das File existiert:
  852.   #+(or UNIX AMIGA ACORN-RISCOS)
  853.   (unless (probe-file file)
  854.     (close (open file :direction :output))
  855.   )
  856.   #+(or DOS OS/2)
  857.     (execute (editor-name) ; das ist der Name des Editors
  858.              (namestring file t) ; file als String
  859.     )
  860.   #+UNIX
  861.     (shell (format nil "~A ~A" (editor-name) (truename file)))
  862.   #+AMIGA
  863.     (shell (format nil "~A \"~A\"" (editor-name) (truename file)))
  864.   #+ACORN-RISCOS
  865.     (shell (format nil "filer_run ~A" (truename file)))
  866. )
  867.  
  868. (defun ed (&optional arg &aux funname sym fun def)
  869.   (if (null arg)
  870.     (edit-file "")
  871.     (if (or (pathnamep arg) (stringp arg))
  872.       (edit-file arg)
  873.       (if (and (cond ((function-name-p arg) (setq funname arg) t)
  874.                      ((functionp arg) (function-name-p (setq funname (sys::%record-ref arg 0))))
  875.                      (t nil)
  876.                )
  877.                (fboundp (setq sym (get-funname-symbol funname)))
  878.                (or (setq fun (macro-function sym))
  879.                    (setq fun (symbol-function sym))
  880.                )
  881.                (functionp fun)
  882.                (or (function-name-p arg) (eql fun arg))
  883.                (setq def (get sym 'sys::definition))
  884.           )
  885.         (let ((tempfile (editor-tempfile)))
  886.           (with-open-file (f tempfile :direction :output)
  887.             (pprint (car def) f)
  888.             (terpri f) (terpri f)
  889.           )
  890.           (let ((date (file-write-date tempfile)))
  891.             (edit-file tempfile)
  892.             (when (> (file-write-date tempfile) date)
  893.               (with-open-file (f tempfile :direction :input)
  894.                 (let ((*package* *package*) ; *PACKAGE* binden
  895.                       (end-of-file "EOF")) ; einmaliges Objekt
  896.                   (loop
  897.                     (let ((obj (read f nil end-of-file)))
  898.                       (when (eql obj end-of-file) (return))
  899.                       (print (evalhook obj nil nil (cdr def)))
  900.               ) ) ) )
  901.               (when (compiled-function-p fun) (compile funname))
  902.           ) )
  903.           funname
  904.         )
  905.         (error-of-type 'error
  906.           (DEUTSCH "~S ist nicht editierbar."
  907.            ENGLISH "~S cannot be edited."
  908.            FRANCAIS "~S ne peut pas Ωtre ΘditΘ.")
  909.           arg
  910. ) ) ) ) )
  911.  
  912. (defun uncompile (arg &aux funname sym fun def)
  913.   (if (and (cond ((function-name-p arg) (setq funname arg) t)
  914.                  ((functionp arg) (function-name-p (setq funname (sys::%record-ref arg 0))))
  915.                  (t nil)
  916.            )
  917.            (fboundp (setq sym (get-funname-symbol funname)))
  918.            (or (setq fun (macro-function sym))
  919.                (setq fun (symbol-function sym))
  920.            )
  921.            (functionp fun)
  922.            (or (function-name-p arg) (eql fun arg))
  923.            (setq def (get sym 'sys::definition))
  924.       )
  925.     (evalhook (car def) nil nil (cdr def))
  926.     (error-of-type 'error
  927.       (DEUTSCH "~S: Quellcode zu ~S nicht verfⁿgbar."
  928.        ENGLISH "~S: source code for ~S not available."
  929.        FRANCAIS "~S : Les sources de ~S ne sont pas prΘsentes.")
  930.       'uncompile funname
  931.     )
  932. ) )
  933.  
  934. ;-------------------------------------------------------------------------------
  935.  
  936. ; Speichert den momentanen Speicherinhalt unter Weglassen ⁿberflⁿssiger
  937. ; Objekte ab als LISPIMAG.MEM.
  938. ; Diese Funktion bekommt keine Argumente und hat keine lokalen Variablen, da
  939. ; sonst in interpretiertem Zustand die Variablenwerte mit abgespeichert wⁿrden.
  940. (defun %saveinitmem ()
  941.   (do-all-symbols (sym) (remprop sym 'sys::definition))
  942.   (when (fboundp 'clos::install-dispatch)
  943.     (do-all-symbols (sym)
  944.       (when (and (fboundp sym) (clos::generic-function-p (symbol-function sym)))
  945.         (let ((gf (symbol-function sym)))
  946.           (when (clos::gf-never-called-p gf)
  947.             (clos::install-dispatch gf)
  948.   ) ) ) ) )
  949.   (setq - nil + nil ++ nil +++ nil * nil ** nil *** nil / nil // nil /// nil)
  950.   (savemem "lispimag.mem")
  951.   (room)
  952. )
  953.  
  954. ; Speichert den momentanen Speicherinhalt ab.
  955. ; LΣuft nur in compiliertem Zustand!
  956. (defun saveinitmem (&optional (filename "lispinit.mem")
  957.                     &key ((:quiet *quiet*) nil) init-function)
  958.   (setq - nil + nil ++ nil +++ nil * nil ** nil *** nil / nil // nil /// nil)
  959.   (if init-function
  960.     (let* ((old-driver *driver*)
  961.            (*driver* #'(lambda ()
  962.                          (setq *driver* old-driver)
  963.                          (funcall init-function)
  964.                          (funcall *driver*)
  965.           ))           )
  966.       (savemem filename)
  967.     )
  968.     (savemem filename)
  969.   )
  970.   (room)
  971. )
  972.  
  973. ;-------------------------------------------------------------------------------
  974.  
  975. ; VervollstΣndigungs-Routine in Verbindung mit der GNU Readline-Library:
  976. ; Input: string die Eingabezeile, (subseq string start end) das zu vervoll-
  977. ; stΣndigende Textstⁿck.
  978. ; Output: eine Liste von Simple-Strings. Leer, falls keine sinnvolle Vervoll-
  979. ; stΣndigung. Sonst CDR = Liste aller sinnvollen VervollstΣndigungen, CAR =
  980. ; sofortige Ersetzung.
  981. #+(or UNIX DOS OS/2)
  982. (defun completion (string start end)
  983.   ; quotiert vervollstΣndigen?
  984.   (let ((start1 start) (quoted nil))
  985.     (when (and (>= start 1) (member (char string (- start 1)) '(#\" #\|)))
  986.       (decf start1) (setq quoted t)
  987.     )
  988.     (let (; Hilfsvariablen beim Sammeln der Symbole:
  989.           knownpart ; Anfangsstⁿck
  990.           knownlen  ; dessen LΣnge
  991.           (L '())   ; sammelnde Liste
  992.          )
  993.       (let* ((functionalp1
  994.                (and (>= start1 1)
  995.                     (equal (subseq string (- start1 1) start1) "(")
  996.              ) )
  997.              (functionalp2
  998.                (and (>= start1 2)
  999.                     (equal (subseq string (- start1 2) start1) "#'")
  1000.              ) )
  1001.              (functionalp ; VervollstΣndigung in funktionaler Position?
  1002.                (or functionalp1 functionalp2)
  1003.              )
  1004.              (gatherer
  1005.                (if functionalp
  1006.                  #'(lambda (sym)
  1007.                      (when (fboundp sym)
  1008.                        (let ((name (symbol-name sym)))
  1009.                          (when (and (>= (length name) knownlen) (string-equal name knownpart :end1 knownlen))
  1010.                            (push name L)
  1011.                    ) ) ) )
  1012.                  #'(lambda (sym)
  1013.                      (let ((name (symbol-name sym)))
  1014.                        (when (and (>= (length name) knownlen) (string-equal name knownpart :end1 knownlen))
  1015.                          (push name L)
  1016.                    ) ) )
  1017.              ) )
  1018.              (package *package*)
  1019.              (mapfun #'sys::map-symbols)
  1020.              (prefix nil))
  1021.         ; Evtl. Packagenamen abspalten:
  1022.         (unless quoted
  1023.           (let ((colon (position #\: string :start start :end end)))
  1024.             (when colon
  1025.               (unless (setq package (find-package (string-upcase (subseq string start colon))))
  1026.                 (return-from completion nil)
  1027.               )
  1028.               (incf colon)
  1029.               (if (and (< colon end) (eql (char string colon) #\:))
  1030.                 (incf colon)
  1031.                 (setq mapfun #'sys::map-external-symbols)
  1032.               )
  1033.               (setq prefix (subseq string start colon))
  1034.               (setq start colon)
  1035.         ) ) )
  1036.         (setq knownpart (subseq string start end))
  1037.         (setq knownlen (length knownpart))
  1038.         (funcall mapfun gatherer package)
  1039.         (when (null L) (return-from completion nil))
  1040.         ; Bei einer Funktion ohne Argumente ergΣnze die schlie▀ende Klammer:
  1041.         (when (and functionalp1
  1042.                    (null (cdr L))
  1043.                    (let ((sym (find-symbol (car L) package)))
  1044.                      (and (fboundp sym)
  1045.                           (functionp (symbol-function sym))
  1046.                           (multiple-value-bind (req-anz opt-anz rest-p key-p)
  1047.                               (function-signature (symbol-function sym))
  1048.                             (and (eql req-anz 0) (eql opt-anz 0) (not rest-p) (not key-p))
  1049.               )    ) )    )
  1050.           (setf (car L) (string-concat (car L) ")"))
  1051.         )
  1052.         ; Kleinbuchstaben:
  1053.         (unless quoted
  1054.           (setq L (mapcar #'string-downcase L))
  1055.         )
  1056.         ; sortieren:
  1057.         (setq L (sort L #'string<))
  1058.         ; gr÷▀tes gemeinsames Anfangsstⁿck suchen:
  1059.         (let ((imax ; (reduce #'min (mapcar #'length L))
  1060.                 (let ((i (length (first L))))
  1061.                   (dolist (s (rest L)) (setq i (min i (length s))))
  1062.                   i
  1063.              )) )
  1064.           (do ((i 0 (1+ i)))
  1065.               ((or (eql i imax)
  1066.                    (let ((c (char (first L) i)))
  1067.                      (dolist (s (rest L) nil) (unless (eql (char s i) c) (return t)))
  1068.                )   )
  1069.                (push (subseq (first L) 0 i) L)
  1070.         ) )   )
  1071.         ; PrΣfix wieder ankleben:
  1072.         (when prefix
  1073.           (mapl #'(lambda (l)
  1074.                     (setf (car l) (string-concat prefix (car l)))
  1075.                   )
  1076.                 L
  1077.         ) )
  1078.         L
  1079. ) ) ) )
  1080.  
  1081. ;-------------------------------------------------------------------------------
  1082.  
  1083. #+(or UNIX OS/2)
  1084. ; Must quote the program name and arguments since Unix shells interpret
  1085. ; characters like #\Space, #\', #\<, #\>, #\$ etc. in a special way. This
  1086. ; kind of quoting should work unless the string contains #\Newline and we
  1087. ; call csh. But we are lucky: only /bin/sh will be used.
  1088. (flet (#+UNIX
  1089.        (shell-quote (string) ; surround a string by single quotes
  1090.          (let ((qchar nil) ; last quote character: nil or #\' or #\"
  1091.                (qstring (make-array 10 :element-type 'string-char
  1092.                                        :adjustable t :fill-pointer 0)))
  1093.            (map nil #'(lambda (c)
  1094.                         (let ((q (if (eql c #\') #\" #\')))
  1095.                           (unless (eql qchar q)
  1096.                             (when qchar (vector-push-extend qchar qstring))
  1097.                             (vector-push-extend (setq qchar q) qstring)
  1098.                           )
  1099.                           (vector-push-extend c qstring)))
  1100.                     string
  1101.            )
  1102.            (when qchar (vector-push-extend qchar qstring))
  1103.            qstring
  1104.        ) )
  1105.        #+(or DOS OS/2)
  1106.        (shell-quote (string) ; surround a string by double quotes
  1107.          ; I have tested Turbo C compiled programs and EMX compiled programs.
  1108.          ; 1. Special characters (space, tab, <, >, ...) lose their effect if
  1109.          ;    they are inside double quotes. To get a double quote, write \".
  1110.          ; 2. Separate the strings by spaces. Turbo C compiled programs don't
  1111.          ;    require this, but EMX programs merge adjacent strings.
  1112.          ; 3. You cannot pass an empty string or a string terminated by \ to
  1113.          ;    Turbo C compiled programs. To pass an empty string to EMX
  1114.          ;    programs, write "". You shouldn't pass a string terminated by \
  1115.          ;    or containing \" to EMX programs.
  1116.          ; Quick and dirty: assume none of these cases occur.
  1117.          (let ((qstring (make-array 10 :element-type 'string-char
  1118.                                        :adjustable t :fill-pointer 0)))
  1119.            (vector-push-extend #\" qstring)
  1120.            (map nil #'(lambda (c)
  1121.                         (when (eql c #\") (vector-push-extend #\\ qstring))
  1122.                         (vector-push-extend c qstring)
  1123.                       )
  1124.                     string
  1125.            )
  1126.            (vector-push-extend #\" qstring)
  1127.            qstring
  1128.        ) )
  1129.        ; conversion to a string that works for a pathname as well
  1130.        (string (object)
  1131.          (if (pathnamep object) (namestring object t) (string object))
  1132.       ))
  1133.   (defun run-shell-command (command &key (input ':terminal) (output ':terminal)
  1134.                                          (if-output-exists ':overwrite)
  1135.                                          #+UNIX (may-exec nil))
  1136.     (case input
  1137.       ((:TERMINAL :STREAM) )
  1138.       (t (if (eq input 'NIL)
  1139.            (setq input #+UNIX "/dev/null" #+(or DOS OS/2) "nul")
  1140.            (setq input (string input))
  1141.          )
  1142.          (setq command (string-concat command " < " (shell-quote input)))
  1143.     ) )
  1144.     (case output
  1145.       ((:TERMINAL :STREAM) )
  1146.       (t (if (eq output 'NIL)
  1147.            (setq output #+UNIX "/dev/null" #+(or DOS OS/2) "nul"
  1148.                  if-output-exists ':OVERWRITE
  1149.            )
  1150.            (progn
  1151.              (setq output (string output))
  1152.              (when (and (eq if-output-exists ':ERROR) (probe-file output))
  1153.                (setq output (pathname output))
  1154.                (error-of-type 'file-error
  1155.                  :pathname output
  1156.                  (DEUTSCH "~S: Eine Datei ~S existiert bereits."
  1157.                   ENGLISH "~S: File ~S already exists"
  1158.                   FRANCAIS "~S : Le fichier ~S existe dΘjα.")
  1159.                  'run-shell-command output
  1160.          ) ) ) )
  1161.          (setq command
  1162.                (string-concat command
  1163.                  (ecase if-output-exists
  1164.                    ((:OVERWRITE :ERROR) " > ")
  1165.                    (:APPEND " >> ")
  1166.                  )
  1167.                  (shell-quote output)
  1168.     ) )  )     )
  1169.     #+UNIX
  1170.     (when may-exec
  1171.       ; Wenn die ausfⁿhrende Shell die "/bin/sh" ist und command eine
  1172.       ; "simple command" im Sinne von sh(1), k÷nnen wir ein wenig optimieren:
  1173.       (setq command (string-concat "exec " command))
  1174.     )
  1175.     (if (eq input ':STREAM)
  1176.       (if (eq output ':STREAM)
  1177.         (make-pipe-io-stream command)
  1178.         (make-pipe-output-stream command)
  1179.       )
  1180.       (if (eq output ':STREAM)
  1181.         (make-pipe-input-stream command)
  1182.         (shell command) ; evtl. " &" anfⁿgen, um Hintergrund-Proze▀ zu bekommen
  1183.     ) )
  1184.   )
  1185.   (defun run-program (program &key (arguments '())
  1186.                                    (input ':terminal) (output ':terminal)
  1187.                                    (if-output-exists ':overwrite))
  1188.     (run-shell-command
  1189.       (apply #'string-concat
  1190.              #+UNIX (shell-quote (string program)) #-UNIX (string program)
  1191.              (mapcan #'(lambda (argument)
  1192.                          (list " " (shell-quote (string argument)))
  1193.                        )
  1194.                      arguments
  1195.       )      )
  1196.       #+UNIX :may-exec #+UNIX t
  1197.       :input input :output output :if-output-exists if-output-exists
  1198.   ) )
  1199. )
  1200.  
  1201.