home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / autoload.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  21.0 KB  |  619 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20.  
  21. ;;;;    AUTOLOAD
  22.  
  23.  
  24. ;;; Go into LISP.
  25. (in-package 'lisp)
  26.  
  27. ;(defvar *features*)
  28.  
  29. (defun eval-feature (x)
  30.   (cond ((atom x)
  31.          (member x *features*
  32.                  :test #'(lambda (a b)
  33.                            (cond ((symbolp a)
  34.                                   (and (symbolp b)
  35.                                        (string-equal (symbol-name a)
  36.                                                      (symbol-name b))))
  37.                                  (t (eql a b))))))
  38.         ((eq (car x) 'and)
  39.          (dolist (x (cdr x) t) (unless (eval-feature x) (return nil))))
  40.         ((eq (car x) 'or)
  41.          (dolist (x (cdr x) nil) (when (eval-feature x) (return t))))
  42.         ((eq (car x) 'not)
  43.      (not (eval-feature (cadr x))))
  44.     (t (error "~S is not a feature expression." x))))
  45.  
  46. ;;; Revised by Marc Rinfret.
  47. (defun sharp-+-reader (stream subchar arg)
  48.   (if (eval-feature (let ((*read-suppress* nil) (*read-base* 10.))
  49.                          (read stream t nil t)))
  50.       (values (read stream t nil t))
  51.       (let ((*read-suppress* t)) (read stream t nil t) (values))))
  52.  
  53. (set-dispatch-macro-character #\# #\+ 'sharp-+-reader)
  54. (set-dispatch-macro-character #\# #\+ 'sharp-+-reader
  55.                               (si::standard-readtable))
  56.  
  57. (defun sharp---reader (stream subchar arg)
  58.   (if (eval-feature (let ((*read-suppress* nil) (*read-base* 10.))
  59.                          (read stream t nil t)))
  60.       (let ((*read-suppress* t)) (read stream t nil t) (values))
  61.       (values (read stream t nil t))))
  62.  
  63. (set-dispatch-macro-character #\# #\- 'sharp---reader)
  64. (set-dispatch-macro-character #\# #\- 'sharp---reader
  65.                               (si::standard-readtable))
  66.  
  67.  
  68.  
  69. (defun lisp-implementation-type () "Kyoto Common Lisp")
  70.  
  71. (defun machine-type () #+sun "SUN"
  72.   #+hp-ux "HP-UX"
  73.   #+eclipse "ECLIPSE"
  74.   #+vax "VAX"
  75.   )
  76.                  
  77. ;(defun machine-type () "DEC VAX11/780")
  78.  
  79. (defun machine-version () (machine-type))
  80. ;(defun machine-version () nil)
  81.  
  82. (defun machine-instance () (machine-type))
  83. ;(defun machine-instance () nil)
  84.  
  85. (defun software-type ()
  86.   #+aosv "AOS/VS"
  87.   #+bsd "BSD"
  88.   #+system-v "SYSTEM-V"
  89.   #+hp-ux "HP-UX")
  90.  
  91. ;(defun software-type () "UNIX BSD")
  92.  
  93. (defun software-version () (software-type))
  94. ;(defun software-version () "4.2BSD")
  95.  
  96. ;(defun short-site-name () "RIMS")
  97. (defun short-site-name () nil)
  98.  
  99. ;(defun long-site-name ()
  100. ;  "Research Institute for Mathematical Sciences, Kyoto University")
  101. (defun long-site-name () nil)
  102.  
  103.  
  104.  
  105. #| A long time ago, there was a technology called AUTOLOADING.
  106.  
  107. ;;; Autoloaders.
  108.  
  109. (defmacro defautoload (name module)
  110.   `(defun ,name (&rest argument-list)
  111.      (autoloader ',name ,module argument-list)))
  112.  
  113. (defun autoloader (name module argument-list)
  114.   (unless (member module *modules* :test #'string-equal)
  115.           (fmakunbound name)
  116.           (load (merge-pathnames module si::*system-directory*)))
  117.   (apply name argument-list))
  118.  
  119. (defmacro defautoloadmacro (name module)
  120.   `(defmacro ,name (&rest argument-list)
  121.      (autoloadermacro ',name ,module argument-list)))
  122.  
  123. (defun autoloadermacro (name module argument-list)
  124.   ;(fmakunbound name)
  125.   (load (merge-pathnames module si::*system-directory*))
  126.   (funcall (macro-function name) (cons name argument-list) nil))
  127.  
  128.  
  129. ;;; DEFAUTOLOAD definitions.
  130.  
  131. (defautoload abs "numlib")
  132. (defautoload acos "numlib")
  133. (defautoload acosh "numlib")
  134. (defautoload adjust-array "arraylib")
  135. (defautoload apropos "packlib")
  136. (defautoload apropos-list "packlib")
  137. (defautoload array-dimensions "arraylib")
  138. (defautoload array-in-bounds-p "arraylib")
  139. (defautoload array-row-major-index "arraylib")
  140. (defautoload asin "numlib")
  141. (defautoload asinh  "numlib")
  142. (defautoload atanh "numlib")
  143. (defautoload bit "arraylib")
  144. (defautoload bit-and "arraylib")
  145. (defautoload bit-andc1 "arraylib")
  146. (defautoload bit-andc2 "arraylib")
  147. (defautoload bit-eqv "arraylib")
  148. (defautoload bit-ior "arraylib")
  149. (defautoload bit-nand "arraylib")
  150. (defautoload bit-nor "arraylib")
  151. (defautoload bit-not "arraylib")
  152. (defautoload bit-orc1 "arraylib")
  153. (defautoload bit-orc2 "arraylib")
  154. (defautoload bit-xor "arraylib")
  155. (defautoload byte "numlib")
  156. (defautoload byte-position "numlib")
  157. (defautoload byte-size "numlib")
  158. (defautoload cis "numlib")
  159. (defautoload coerce "predlib")
  160. (defautoload concatenate "seq")
  161. (defautoload cosh "numlib")
  162. (defautoload count "seqlib")
  163. (defautoload count-if "seqlib")
  164. (defautoload count-if-not "seqlib")
  165. (defautoload decode-universal-time "mislib")
  166. (defautoload delete "seqlib")
  167. (defautoload delete-duplicates "seqlib")
  168. (defautoload delete-if "seqlib")
  169. (defautoload delete-if-not  "seqlib")
  170. (defautoload deposit-field "numlib")
  171. (defautoload describe "describe")
  172. (defautoload dpb "numlib")
  173. (defautoload dribble "iolib")
  174. (defautoload encode-universal-time "mislib")
  175. (defautoload every "seq")
  176. (defautoload fceiling "numlib")
  177. (defautoload ffloor "numlib")
  178. (defautoload fill "seqlib")
  179. (defautoload find "seqlib")
  180. (defautoload find-all-symbols "packlib")
  181. (defautoload find-if "seqlib")
  182. (defautoload find-if-not "seqlib")
  183. (defautoload fround "numlib")
  184. (defautoload ftruncate "numlib")
  185. #+unix (defautoload get-decoded-time "mislib")
  186. #+aosvs (defautoload get-universal-time "mislib")
  187. (defautoload get-setf-method "setf")
  188. (defautoload get-setf-method-multiple-value "setf")
  189. (defautoload inspect "describe")
  190. (defautoload intersection "listlib")
  191. (defautoload isqrt "numlib")
  192. (defautoload ldb "numlib")
  193. (defautoload ldb-test "numlib")
  194. (defautoload logandc1 "numlib")
  195. (defautoload logandc2 "numlib")
  196. (defautoload lognand "numlib")
  197. (defautoload lognor "numlib")
  198. (defautoload lognot "numlib")
  199. (defautoload logorc1 "numlib")
  200. (defautoload logorc2 "numlib")
  201. (defautoload logtest "numlib")
  202. (defautoload make-array "arraylib")
  203. (defautoload make-sequence "seq")
  204. (defautoload map "seq")
  205. (defautoload mask-field "numlib")
  206. (defautoload merge "seqlib")
  207. (defautoload mismatch "seqlib")
  208. (defautoload nintersection "listlib")
  209. (defautoload notany "seq")
  210. (defautoload notevery "seq")
  211. (defautoload nset-difference "listlib")
  212. (defautoload nset-exclusive-or "listlib")
  213. (defautoload nsubstitute "seqlib")
  214. (defautoload nsubstitute-if "seqlib")
  215. (defautoload nsubstitute-if-not "seqlib")
  216. (defautoload nunion "listlib")
  217. (defautoload phase "numlib")
  218. (defautoload position "seqlib")
  219. (defautoload position-if "seqlib")
  220. (defautoload position-if-not "seqlib")
  221. (defautoload prin1-to-string "iolib")
  222. (defautoload princ-to-string "iolib")
  223. (defautoload rational "numlib")
  224. (defautoload rationalize "numlib")
  225. (defautoload read-from-string "iolib")
  226. (defautoload reduce "seqlib")
  227. (defautoload remove "seqlib")
  228. (defautoload remove-duplicates "seqlib")
  229. (defautoload remove-if "seqlib")
  230. (defautoload remove-if-not "seqlib")
  231. (defautoload replace "seqlib")
  232. (defautoload sbit "arraylib")
  233. (defautoload search "seqlib")
  234. (defautoload set-difference "listlib")
  235. (defautoload set-exclusive-or "listlib")
  236. (defautoload signum "numlib")
  237. (defautoload sinh "numlib")
  238. (defautoload some "seq")
  239. (defautoload sort "seqlib")
  240. (defautoload stable-sort "seqlib")
  241. (defautoload subsetp "listlib")
  242. (defautoload substitute "seqlib")
  243. (defautoload substitute-if "seqlib")
  244. (defautoload substitute-if-not "seqlib")
  245. (defautoload subtypep "predlib")
  246. (defautoload tanh "numlib")
  247. (defautoload typep "predlib")
  248. (defautoload union "listlib")
  249. (defautoload vector "arraylib")
  250. (defautoload vector-pop "arraylib")
  251. (defautoload vector-push "arraylib")
  252. (defautoload vector-extend "arraylib")
  253. (defautoload write-to-string "iolib")
  254. (defautoload y-or-n-p "iolib")
  255. (defautoload yes-or-no-p "iolib")
  256.  
  257. (set-dispatch-macro-character #\# #\a 'si::sharp-a-reader)
  258. (set-dispatch-macro-character #\# #\A 'si::sharp-a-reader)
  259. (defautoload si::sharp-a-reader "iolib")
  260. (set-dispatch-macro-character #\# #\s 'si::sharp-s-reader)
  261. (set-dispatch-macro-character #\# #\S 'si::sharp-s-reader)
  262. (defautoload si::sharp-s-reader "iolib")
  263.  
  264.  
  265. ;;; DEFAUTOLOADMACRO definitions.
  266.  
  267. (defautoloadmacro assert "assert")
  268. (defautoloadmacro ccase "assert")
  269. (defautoloadmacro check-type "assert")
  270. (defautoloadmacro ctypecase "assert")
  271. (defautoloadmacro decf "setf")
  272. (defautoloadmacro define-modify-macro "setf")
  273. (defautoloadmacro define-setf-method "setf")
  274. (defautoloadmacro defsetf "setf")
  275. (defautoloadmacro defstruct "defstruct")
  276. (defautoloadmacro deftype "predlib")
  277. (defautoloadmacro do-all-symbols "packlib")
  278. (defautoloadmacro do-external-symbols "packlib")
  279. (defautoloadmacro do-symbols "packlib")
  280. (defautoloadmacro ecase "assert")
  281. (defautoloadmacro etypecase "assert")
  282. (defautoloadmacro incf "setf")
  283. (defautoloadmacro pop "setf")
  284. (defautoloadmacro push "setf")
  285. (defautoloadmacro pushnew "setf")
  286. (defautoloadmacro remf "setf")
  287. (defautoloadmacro rotatef "setf")
  288. (defautoloadmacro setf "setf")
  289. (defautoloadmacro shiftf "setf")
  290. (defautoloadmacro step "trace")
  291. (defautoloadmacro time "mislib")
  292. (defautoloadmacro trace "trace")
  293. (defautoloadmacro typecase "assert")
  294. (defautoloadmacro untrace "trace")
  295. (defautoloadmacro with-input-from-string "iolib")
  296. (defautoloadmacro with-open-file "iolib")
  297. (defautoloadmacro with-open-stream "iolib")
  298. (defautoloadmacro with-output-to-string "iolib")
  299.  
  300. |#
  301.  
  302. ;;; Compiler functions.
  303.  
  304. (defun proclaim (d)
  305.        (when (eq (car d) 'special) (mapc #'si:*make-special (cdr d))))
  306.  
  307. (defun proclamation (d)
  308.   (and (eq (car d) 'special)
  309.        (dolist (var (cdr d) t)
  310.                (unless (si:specialp var) (return nil)))))
  311.  
  312. (defun compile-file (&rest args)
  313.        (error "COMPILE-FILE is not defined in this load module."))
  314. (defun compile (&rest args)
  315.        (error "COMPILE is not defined in this load module."))
  316. (defun disassemble (&rest args)
  317.        (error "DISASSEMBLE is not defined in this load module."))
  318.  
  319.  
  320. ;;; Editor.
  321.  
  322. #+unix
  323. (defun get-decoded-time ()
  324.   (decode-universal-time (get-universal-time)))
  325.  
  326. #-unix
  327. (defun get-universal-time ()
  328.   (multiple-value-bind (sec min h d m y dow dstp tz)
  329.       (get-decoded-time)
  330.     (encode-universal-time sec min h d m y tz)))
  331.  
  332. #+unix
  333. (defun ed (&optional filename)
  334.   (system (format nil "vi ~A" filename)))
  335.  
  336. #+aosvs
  337. (progn
  338. (defvar *ed-filename* "GAZONK.LSP")
  339. (defvar *ed-position* "0")
  340.  
  341. (defun ed (&optional filename)
  342.   (let (str str-len load-file lstart plen (delete-p nil))
  343.     (when filename
  344.           (setq filename
  345.                 (namestring (merge-pathnames filename #".LSP"))))
  346.     (when (and filename (not (string-equal *ed-filename* filename)))
  347.           (setq *ed-position* "0")
  348.           (setq *ed-filename* filename))
  349.     (process (format nil "~A"
  350.                      (namestring (merge-pathnames "FECL2.PR"
  351.                                                   si::*system-directory*)))
  352.              (format nil "FECL2/LISP,~A,~D" *ed-filename* *ed-position*)
  353.              :block t :ioc t)
  354.     (setq str (last-termination-message))
  355.     (when (or (not (stringp str)) (< (setq str-len (length str)) 21))
  356.           (return-from ed str))
  357.     (when (string/= (subseq str 0 5) "LISP ")
  358.           (return-from ed str))
  359.     (setq *ed-position* (string-left-trim '(#\Space) (subseq str 5 15)))
  360.     (setq plen (parse-integer (subseq str 16 19)))
  361.     (setq *ed-filename* (subseq str 20 (+ 20 plen)))
  362.     (setq lstart (+ 21 plen))
  363.     (when (> str-len lstart)
  364.           (setq str (subseq str lstart str-len))
  365.           (unwind-protect
  366.            (progn (setq delete-p (if (char= (char str 1) #\T) t nil))
  367.                   (load (setq load-file (subseq str 2 (length str)))))
  368.            (when delete-p (delete-file (truename load-file)))))
  369.     t))
  370. )
  371.  
  372.  
  373. ;;; Allocator.
  374.  
  375. (import 'si::allocate)
  376. (export '(allocate
  377.       ;allocated-pages maximum-allocatable-pages
  378.           ;allocate-contiguous-pages
  379.           ;allocated-contiguous-pages maximum-contiguous-pages
  380.           ;allocate-relocatable-pages allocated-relocatable-pages 
  381.           sfun gfun cfun cclosure spice structure))
  382.  
  383. ;(defvar type-character-alist
  384. ;             '((cons . #\.)
  385. ;               (fixnum . #\N)
  386. ;               (bignum . #\B)
  387. ;               (ratio . #\R)
  388. ;               (short-float . #\F)
  389. ;               (long-float . #\L)
  390. ;               (complex . #\C)
  391. ;               (character . #\#)
  392. ;               (symbol . #\|)
  393. ;               (package . #\:)
  394. ;               (hash-table . #\h)
  395. ;               (array . #\a)
  396. ;               (vector . #\v)
  397. ;               (string . #\")
  398. ;               (bit-vector . #\b)
  399. ;               (structure . #\S)
  400. ;           (sfun . #\g)
  401. ;               (stream . #\s)
  402. ;               (random-state . #\$)
  403. ;               (readtable . #\r)
  404. ;               (pathname . #\p)
  405. ;               (cfun . #\f)
  406. ;           (vfun . #\V)
  407. ;               (cclosure . #\c)
  408. ;               (spice . #\!)))
  409. ;
  410. ;(defun get-type-character (type)
  411. ;  (let ((a (assoc type type-character-alist)))
  412. ;    (unless a
  413. ;            (error "~S is not an implementation type.~%~
  414. ;                   It should be one of:~%~
  415. ;                   ~{~10T~S~^~30T~S~^~50T~S~%~}~%"
  416. ;                   type
  417. ;                   (mapcar #'car type-character-alist)))
  418. ;    (cdr a)))
  419.  
  420. ;(defun allocate (type quantity &optional really-allocate)
  421. ;  (si:alloc (get-type-character type) quantity really-allocate))
  422.  
  423. ;(defun allocated-pages (type)
  424. ;  (si:npage (get-type-character type)))
  425.  
  426. ;(defun maximum-allocatable-pages (type)
  427. ;  (si:maxpage (get-type-character type)))
  428.  
  429. ;(defun allocate-contiguous-pages (quantity &optional really-allocate)
  430. ;  (si::alloc-contpage quantity really-allocate))
  431.  
  432. ;(defun allocated-contiguous-pages ()
  433. ;  (si:ncbpage))
  434.  
  435. ;(defun maximum-contiguous-pages ()
  436. ;  (si::maxcbpage))
  437.  
  438. ;(defun allocate-relocatable-pages (quantity &optional really-allocate)
  439. ;  (si::alloc-relpage quantity))
  440.  
  441. ;(defun allocated-relocatable-pages ()
  442. ;  (si::nrbpage))
  443.  
  444. (defvar *type-list*
  445.         '(cons
  446.           fixnum bignum ratio short-float long-float complex
  447.           character symbol package hash-table
  448.           array vector string bit-vector
  449.           structure stream random-state readtable pathname
  450.           cfun cclosure sfun gfun cfdata spice fat-string ))
  451.  
  452. (defun room (&optional x)
  453.   (let ((l (multiple-value-list (si:room-report)))
  454.         maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage
  455.         rbused rbfree nrbpage
  456.         info-list link-alist)
  457.     (setq maxpage (nth 0 l) leftpage (nth 1 l)
  458.           ncbpage (nth 2 l) maxcbpage (nth 3 l) ncb (nth 4 l)
  459.           cbgbccount (nth 5 l)
  460.           holepage (nth 6 l)
  461.           rbused (nth 7 l) rbfree (nth 8 l) nrbpage (nth 9 l)
  462.           rbgbccount (nth 10 l)
  463.           l (nthcdr 11 l))
  464.     (do ((l l (nthcdr 5 l))
  465.          (tl *type-list* (cdr tl))
  466.          (i 0 (+ i (if (nth 2 l) (nth 2 l) 0))))
  467.         ((null l) (setq npage i))
  468.       (let ((typename (car tl))
  469.             (nused (nth 0 l))
  470.             (nfree (nth 1 l))
  471.             (npage (nth 2 l))
  472.             (maxpage (nth 3 l))
  473.             (gbccount (nth 4 l)))
  474.         (if nused
  475.             (push (list typename npage maxpage
  476.                         (if (zerop (+ nused nfree))
  477.                             0
  478.                             (/ nused 0.01 (+ nused nfree)))
  479.                         (if (zerop gbccount) nil gbccount))
  480.                   info-list)
  481.             (let ((a (assoc (nth nfree *type-list*) link-alist)))
  482.                  (if a
  483.                      (nconc a (list typename))
  484.                      (push (list (nth nfree *type-list*) typename)
  485.                            link-alist))))))
  486.     (dolist (info (reverse info-list))
  487.       (apply #'format t "~4D/~D~10T~5,1F%~@[~3D~]~20T~{~A~^ ~}"
  488.              (append (cdr info)
  489.                      (if  (assoc (car info) link-alist)
  490.                           (list (assoc (car info) link-alist))
  491.                           (list (list (car info))))))
  492.       (terpri)
  493.       )
  494.     (terpri)
  495.     (format t "~4D/~D~16T~@[~3D~]~20Tcontiguous (~D blocks)~%"
  496.             ncbpage maxcbpage (if (zerop cbgbccount) nil cbgbccount) ncb)
  497.     (format t "~5T~D~20Thole~%" holepage)
  498.     (format t "~5T~D~10T~5,1F%~@[~3D~]~20Trelocatable~%~%"
  499.             nrbpage (/ rbused 0.01 (+ rbused rbfree))
  500.             (if (zerop rbgbccount) nil rbgbccount))
  501.     (format t "~5D pages for cells~%" npage)
  502.     (format t "~5D total pages~%" (+ npage ncbpage holepage nrbpage))
  503.     (format t "~5D pages available~%" leftpage)
  504.     (format t "~5D pages in heap but not gc'd + pages needed for gc marking~%"
  505.         (- maxpage (+ npage ncbpage holepage nrbpage leftpage)))
  506.     (format t "~5D maximum pages~%" maxpage)
  507.     (values)
  508.     ))
  509.  
  510.  
  511. ;;; C Interface.
  512.  
  513. (defmacro Clines (&rest r) nil)
  514. (defmacro defCfun (&rest r) nil)
  515. (defmacro defentry (&rest r) nil)
  516.  
  517. (defmacro defla (&rest r) (cons 'defun r))
  518.  
  519. ;;; Help.
  520.  
  521. (export '(help help*))
  522.  
  523. (defun help (&optional (symbol nil s))
  524.   (if s (si::print-doc symbol)
  525.       (progn
  526.         (princ "
  527. Welcome to Kyoto Common Lisp (KCL for short).
  528. Here are the few functions you should learn first.
  529.  
  530.     (HELP symbol) prints the online documentation associated with the
  531.     symbol.  For example, (HELP 'CONS) will print the useful information
  532.     about the CONS function, the CONS data type, and so on.
  533.  
  534.     (HELP* string) prints the online documentation associated with those
  535.     symbols whose print-names have the string as substring.  For example,
  536.     (HELP* \"PROG\") will print the documentation of the symbols such as
  537.     PROG, PROGN, and MULTIPLE-VALUE-PROG1.
  538.  
  539.     (BYE) ends the current KCL session.
  540.  
  541. For the precise language specification, refere to Guy Steele's \"Common Lisp,
  542. the Language\" and our \"KCL Report\".  \"KCL Dictionary\", the hard-copied
  543. version of KCL online documentation, will be useful as a handbook.
  544.  
  545. Good luck!                 Taiichi Yuasa and Masami Hagiya
  546.                         Kyoto, Japan; March 1986")
  547.         (values))))
  548.  
  549. (defun help* (string &optional (package (find-package "LISP")))
  550.   (si::apropos-doc string package))
  551.  
  552. ;;; Pretty-print-formats.
  553. ;;;
  554. ;;;    The number N as the property of a symbol SYMBOL indicates that,
  555. ;;;    in the form (SYMBOL f1 ... fN fN+1 ... fM), the subforms fN+1,...,fM
  556. ;;;    are the 'body' of the form and thus are treated in a special way by
  557. ;;;    the KCL pretty-printer.
  558.  
  559. (setf (get 'lambda 'si:pretty-print-format) 1)
  560. (setf (get 'lambda-block 'si:pretty-print-format) 2)
  561. (setf (get 'lambda-closure 'si:pretty-print-format) 4)
  562. (setf (get 'lambda-block-closure 'si:pretty-print-format) 5)
  563.  
  564. (setf (get 'block 'si:pretty-print-format) 1)
  565. (setf (get 'case 'si:pretty-print-format) 1)
  566. (setf (get 'catch 'si:pretty-print-format) 1)
  567. (setf (get 'ccase 'si:pretty-print-format) 1)
  568. (setf (get 'clines 'si:pretty-print-format) 0)
  569. (setf (get 'compiler-let 'si:pretty-print-format) 1)
  570. (setf (get 'cond 'si:pretty-print-format) 0)
  571. (setf (get 'ctypecase 'si:pretty-print-format) 1)
  572. (setf (get 'defcfun 'si:pretty-print-format) 2)
  573. (setf (get 'define-setf-method 'si:pretty-print-format) 2)
  574. (setf (get 'defla 'si:pretty-print-format) 2)
  575. (setf (get 'defmacro 'si:pretty-print-format) 2)
  576. (setf (get 'defsetf 'si:pretty-print-format) 3)
  577. (setf (get 'defstruct 'si:pretty-print-format) 1)
  578. (setf (get 'deftype 'si:pretty-print-format) 2)
  579. (setf (get 'defun 'si:pretty-print-format) 2)
  580. (setf (get 'do 'si:pretty-print-format) 2)
  581. (setf (get 'do* 'si:pretty-print-format) 2)
  582. (setf (get 'do-symbols 'si:pretty-print-format) 1)
  583. (setf (get 'do-all-symbols 'si:pretty-print-format) 1)
  584. (setf (get 'do-external-symbols 'si:pretty-print-format) 1)
  585. (setf (get 'dolist 'si:pretty-print-format) 1)
  586. (setf (get 'dotimes 'si:pretty-print-format) 1)
  587. (setf (get 'ecase 'si:pretty-print-format) 1)
  588. (setf (get 'etypecase 'si:pretty-print-format) 1)
  589. (setf (get 'eval-when 'si:pretty-print-format) 1)
  590. (setf (get 'flet 'si:pretty-print-format) 1)
  591. (setf (get 'labels 'si:pretty-print-format) 1)
  592. (setf (get 'let 'si:pretty-print-format) 1)
  593. (setf (get 'let* 'si:pretty-print-format) 1)
  594. (setf (get 'locally 'si:pretty-print-format) 0)
  595. (setf (get 'loop 'si:pretty-print-format) 0)
  596. (setf (get 'macrolet 'si:pretty-print-format) 1)
  597. (setf (get 'multiple-value-bind 'si:pretty-print-format) 2)
  598. (setf (get 'multiple-value-prog1 'si:pretty-print-format) 1)
  599. (setf (get 'prog 'si:pretty-print-format) 1)
  600. (setf (get 'prog* 'si:pretty-print-format) 1)
  601. (setf (get 'prog1 'si:pretty-print-format) 1)
  602. (setf (get 'prog2 'si:pretty-print-format) 2)
  603. (setf (get 'progn 'si:pretty-print-format) 0)
  604. (setf (get 'progv 'si:pretty-print-format) 2)
  605. (setf (get 'return 'si:pretty-print-format) 0)
  606. (setf (get 'return-from 'si:pretty-print-format) 1)
  607. (setf (get 'tagbody 'si:pretty-print-format) 0)
  608. (setf (get 'the 'si:pretty-print-format) 1)
  609. (setf (get 'throw 'si:pretty-print-format) 1)
  610. (setf (get 'typecase 'si:pretty-print-format) 1)
  611. (setf (get 'unless 'si:pretty-print-format) 1)
  612. (setf (get 'unwind-protect 'si:pretty-print-format) 0)
  613. (setf (get 'when 'si:pretty-print-format) 1)
  614. (setf (get 'with-input-from-string 'si:pretty-print-format) 1)
  615. (setf (get 'with-open-file 'si:pretty-print-format) 1)
  616. (setf (get 'with-open-stream 'si:pretty-print-format) 1)
  617. (setf (get 'with-output-to-string 'si:pretty-print-format) 1)
  618.  
  619.